maxjhandsome
/
llvm-project
forked from OSchip/llvm-project
1
0
Fork 0
Code Issues Pull Requests Packages Releases Wiki Activity

[flang] Changes to check for constraint C1140 

This constraint prohibits deallocation of polymorphic entities in a DO
CONCURRENT.

Section 9.7.3.2 specifies the situations that might cause deallocation
of a polymorphic entity. The ones that are applicable to a DO CONCURRENT
are exiting from a block that declares such variables, intrinsic
assignment, and an actual DEALLOCATE statement. This section also
specifies (paragraph 8) that deallocation of a derived type causes
deallocation of all of its allocatable subobjects.

Section 10.2.1.3 specifies what happens during intrinsic assignment.
Paragraph 3 states If the variable is an allocated allocatable variable,
it is deallocated if expr is an array of different shape, any
corresponding length type parameter values of the variable and expr
differ, or the variable is polymorphic and the dynamic type or any
corresponding kind type parameter values of the variable and expr
differ." Thus, an allocatable polymorphic variable on the left hand side
of an assignment statement gets deallocated. Paragraph 13 states that
  "For a noncoarray allocatable component the following sequence of
   operations is applied.
      (1) If the component of the variable is allocated, it is deallocated."

Thus, a variable on the left-hand side of an assignment statement might have noncorray allocatable components. Such components will be deallocated.
Deallocation can be caused by exiting from a block where the entity is
declared, from an assignment, and from direct deallocation.

Original-commit: flang-compiler/f18@7d1932d344
Reviewed-on: https://github.com/flang-compiler/f18/pull/814
This commit is contained in:
Pete Steinfeld 2019-11-05 10:18:33 -08:00
parent 96a6b8c8d0
commit fd76cc47c5
6 changed files with 399 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

157
flang/lib/semantics/check-do.cc
View File

@ -64,6 +64,125 @@ public:
template<typename T> bool Pre(const T &) { return true; }
template<typename T> void Post(const T &) {}
template<typename T> bool Pre(const parser::Statement<T> &statement) {
currentStatementSourcePosition_ = statement.source;
if (statement.label.has_value()) {
labels_.insert(*statement.label);
}
return true;
}
// C1140 -- Can't deallocate a polymorphic entity in a DO CONCURRENT.
// Deallocation can be caused by exiting a block that declares an allocatable
// entity, assignment to an allocatable variable, or an actual DEALLOCATE
// statement
//
// Note also that the deallocation of a derived type entity might cause the
// invocation of an IMPURE final subroutine.
//
// Predicate for deallocations caused by block exit and direct deallocation
static bool DeallocateAll(const Symbol &) { return true; }
// Predicate for deallocations caused by intrinsic assignment
static bool DeallocateNonCoarray(const Symbol &component) {
return !IsCoarray(component);
}
static bool WillDeallocatePolymorphic(const Symbol &entity,
const std::function<bool(const Symbol &)> &WillDeallocate) {
return WillDeallocate(entity) && IsPolymorphicAllocatable(entity);
}
// Is it possible that we will we deallocate a polymorphic entity or one
// of its components?
static bool MightDeallocatePolymorphic(const Symbol &entity,
const std::function<bool(const Symbol &)> &WillDeallocate) {
if (const Symbol * root{GetAssociationRoot(entity)}) {
// Check the entity itself, no coarray exception here
if (IsPolymorphicAllocatable(*root)) {
return true;
}
// Check the components
if (const auto *details{root->detailsIf<ObjectEntityDetails>()}) {
if (const DeclTypeSpec * entityType{details->type()}) {
if (const DerivedTypeSpec * derivedType{entityType->AsDerived()}) {
UltimateComponentIterator ultimates{*derivedType};
for (const auto &ultimate : ultimates) {
if (WillDeallocatePolymorphic(ultimate, WillDeallocate)) {
return true;
}
}
}
}
}
}
return false;
}
// Deallocation caused by block exit
// Allocatable entities and all of their allocatable subcomponents will be
// deallocated. This test is different from the other two because it does
// not deallocate in cases where the entity itself is not allocatable but
// has allocatable polymorphic components
void Post(const parser::BlockConstruct &blockConstruct) {
const auto &endBlockStmt{
std::get<parser::Statement<parser::EndBlockStmt>>(blockConstruct.t)};
const Scope &blockScope{context_.FindScope(endBlockStmt.source)};
const Scope &doScope{context_.FindScope(doConcurrentSourcePosition_)};
if (DoesScopeContain(&doScope, blockScope)) {
for (auto &pair : blockScope) {
Symbol &entity{*pair.second};
if (IsAllocatable(entity) && !entity.attrs().test(Attr::SAVE) &&
MightDeallocatePolymorphic(entity, DeallocateAll)) {
context_.SayWithDecl(entity, endBlockStmt.source,
"Deallocation of a polymorphic entity caused by block"
" exit not allowed in DO CONCURRENT"_err_en_US);
}
// TODO: Check for deallocation of a variable with an IMPURE FINAL
// subroutine
}
}
}
// Deallocation caused by assignment
// Note that this case does not cause deallocation of coarray components
void Post(const parser::AssignmentStmt &stmt) {
const auto &variable{std::get<parser::Variable>(stmt.t)};
if (const Symbol * entity{GetLastName(variable).symbol}) {
if (MightDeallocatePolymorphic(*entity, DeallocateNonCoarray)) {
context_.SayWithDecl(*entity, variable.GetSource(),
"Deallocation of a polymorphic entity caused by "
"assignment not allowed in DO CONCURRENT"_err_en_US);
// TODO: Check for deallocation of a variable with an IMPURE FINAL
// subroutine
}
}
}
// Deallocation from a DEALLOCATE statement
// This case is different because DEALLOCATE statements deallocate both
// ALLOCATABLE and POINTER entities
void Post(const parser::DeallocateStmt &stmt) {
const auto &allocateObjectList{
std::get<std::list<parser::AllocateObject>>(stmt.t)};
for (const auto &allocateObject : allocateObjectList) {
const parser::Name &name{GetLastName(allocateObject)};
if (name.symbol) {
const Symbol &entity{*name.symbol};
const DeclTypeSpec *entityType{entity.GetType()};
if ((entityType && entityType->IsPolymorphic()) || // POINTER case
MightDeallocatePolymorphic(entity, DeallocateAll)) {
context_.SayWithDecl(entity, currentStatementSourcePosition_,
"Deallocation of a polymorphic entity not allowed in DO"
" CONCURRENT"_err_en_US);
}
// TODO: Check for deallocation of a variable with an IMPURE FINAL
// subroutine
}
}
}
// C1137 -- No image control statements in a DO CONCURRENT
void Post(const parser::ExecutableConstruct &construct) {
if (IsImageControlStmt(construct)) {
@ -79,14 +198,6 @@ public:
}
}
template<typename T> bool Pre(const parser::Statement<T> &statement) {
currentStatementSourcePosition_ = statement.source;
if (statement.label) {
labels_.insert(*statement.label);
}
return true;
}
// C1167 -- EXIT statements can't exit a DO CONCURRENT
bool Pre(const parser::WhereConstruct &s) {
AddName(MaybeGetConstructName(s));
@ -199,7 +310,6 @@ private:
return common::GetPtrFromOptional(std::get<0>(a.t));
}
bool anyObjectIsPolymorphic() { return false; } // FIXME placeholder
bool fromScope(const Symbol &symbol, const std::string &moduleName) {
if (symbol.GetUltimate().owner().IsModule() &&
symbol.GetUltimate().owner().GetName().value().ToString() ==
@ -303,14 +413,11 @@ public:
if (IsVariableName(*symbol)) {
const Scope &variableScope{symbol->owner()};
if (DoesScopeContain(&variableScope, blockScope_)) {
context_
.Say(name.source,
"Variable '%s' from an enclosing scope referenced in a DO "
"CONCURRENT with DEFAULT(NONE) must appear in a "
"locality-spec"_err_en_US,
name.source)
.Attach(symbol->name(), "Declaration of variable '%s'"_en_US,
symbol->name());
context_.SayWithDecl(*symbol, name.source,
"Variable '%s' from an enclosing scope referenced in DO "
"CONCURRENT with DEFAULT(NONE) must appear in a "
"locality-spec"_err_en_US,
symbol->name());
}
}
}
@ -473,25 +580,21 @@ private:
SymbolSet references{GatherSymbolsFromExpression(mask.thing.thing.value())};
for (const Symbol *ref : references) {
if (IsProcedure(*ref) && !IsPureProcedure(*ref)) {
const parser::CharBlock &name{ref->name()};
context_
.Say(currentStatementSourcePosition_,
"Concurrent-header mask expression cannot reference an impure"
" procedure"_err_en_US)
.Attach(name, "Declaration of impure procedure '%s'"_en_US, name);
context_.SayWithDecl(*ref, currentStatementSourcePosition_,
"Concurrent-header mask expression cannot reference an impure"
" procedure"_err_en_US);
return;
}
}
}
void CheckNoCollisions(const SymbolSet &refs, const SymbolSet &uses,
const parser::MessageFixedText &errorMessage,
parser::MessageFixedText &&errorMessage,
const parser::CharBlock &refPosition) const {
for (const Symbol *ref : refs) {
if (uses.find(ref) != uses.end()) {
const parser::CharBlock &name{ref->name()};
context_.Say(refPosition, errorMessage, name)
.Attach(name, "Declaration of '%s'"_en_US, name);
context_.SayWithDecl(
*ref, refPosition, std::move(errorMessage), ref->name());
return;
}
}

7
flang/lib/semantics/semantics.h
View File

@ -17,6 +17,7 @@
#include "scope.h"
#include "../common/Fortran-features.h"
#include "symbol.h"
#include "../evaluate/common.h"
#include "../evaluate/intrinsics.h"
#include "../parser/message.h"
@ -138,6 +139,12 @@ public:
parser::Message &Say(parser::Message &&msg) {
return messages_.Say(std::move(msg));
}
template<typename... A>
void SayWithDecl(const Symbol &symbol, const parser::CharBlock &at,
parser::MessageFixedText &&msg, A &&... args) {
auto &message{Say(at, std::move(msg), args...)};
evaluate::AttachDeclaration(&message, &symbol);
}
const Scope &FindScope(parser::CharBlock) const;
Scope &FindScope(parser::CharBlock);

43
flang/lib/semantics/tools.cc
View File

@ -582,6 +582,35 @@ const Symbol *IsExternalInPureContext(
return nullptr;
}
PotentialComponentIterator::const_iterator FindPolymorphicPotentialComponent(
const DerivedTypeSpec &derived) {
PotentialComponentIterator potentials{derived};
return std::find_if(
potentials.begin(), potentials.end(), [](const Symbol &component) {
if (const auto *details{component.detailsIf<ObjectEntityDetails>()}) {
const DeclTypeSpec *type{details->type()};
return type && type->IsPolymorphic();
}
return false;
});
}
bool IsOrContainsPolymorphicComponent(const Symbol &symbol) {
if (const Symbol * root{GetAssociationRoot(symbol)}) {
if (const auto *details{root->detailsIf<ObjectEntityDetails>()}) {
if (const DeclTypeSpec * type{details->type()}) {
if (type->IsPolymorphic()) {
return true;
}
if (const DerivedTypeSpec * derived{type->AsDerived()}) {
return (bool)FindPolymorphicPotentialComponent(*derived);
}
}
}
}
return false;
}
bool InProtectedContext(const Symbol &symbol, const Scope &currentScope) {
return IsProtected(symbol) && !IsHostAssociated(symbol, currentScope);
}
@ -770,17 +799,17 @@ bool HasCoarray(const parser::Expr &expression) {
return false;
}
bool IsPolymorphicAllocatable(const Symbol &symbol) {
if (IsAllocatable(symbol)) {
if (const auto *details{symbol.detailsIf<ObjectEntityDetails>()}) {
if (const DeclTypeSpec * type{details->type()}) {
return type->IsPolymorphic();
}
}
bool IsPolymorphic(const Symbol &symbol) {
if (const DeclTypeSpec * type{symbol.GetType()}) {
return type->IsPolymorphic();
}
return false;
}
bool IsPolymorphicAllocatable(const Symbol &symbol) {
return IsAllocatable(symbol) && IsPolymorphic(symbol);
}
static const DeclTypeSpec &InstantiateIntrinsicType(Scope &scope,
const DeclTypeSpec &spec, SemanticsContext &semanticsContext) {
const IntrinsicTypeSpec *intrinsic{spec.AsIntrinsic()};

1
flang/test/semantics/CMakeLists.txt
View File

@ -142,6 +142,7 @@ set(ERROR_TESTS
doconcurrent01.f90
doconcurrent05.f90
doconcurrent06.f90
doconcurrent08.f90
dosemantics01.f90
dosemantics02.f90
dosemantics03.f90

219
flang/test/semantics/doconcurrent08.f90 Normal file
View File

@ -0,0 +1,219 @@
! Copyright (c) 2019, NVIDIA CORPORATION. All rights reserved.
!
! Licensed under the Apache License, Version 2.0 (the "License");
! you may not use this file except in compliance with the License.
! You may obtain a copy of the License at
!
! http://www.apache.org/licenses/LICENSE-2.0
!
! Unless required by applicable law or agreed to in writing, software
! distributed under the License is distributed on an "AS IS" BASIS,
! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
! See the License for the specific language governing permissions and
! limitations under the License.
!
! C1140 -- A statement that might result in the deallocation of a polymorphic
! entity shall not appear within a DO CONCURRENT construct.
module m1
! Base type with scalar components
type :: Base
integer :: baseField1
end type
! Child type so we can allocate polymorphic entities
type, extends(Base) :: ChildType
integer :: childField
end type
! Type with a polymorphic, allocatable component
type, extends(Base) :: HasAllocPolyType
class(Base), allocatable :: allocPolyField
end type
! Type with a allocatable, coarray component
type :: HasAllocCoarrayType
type(Base), allocatable, codimension[:] :: allocCoarrayField
end type
! Type with a polymorphic, allocatable, coarray component
type :: HasAllocPolyCoarrayType
class(Base), allocatable, codimension[:] :: allocPolyCoarrayField
end type
! Type with a polymorphic, pointer component
type, extends(Base) :: HasPointerPolyType
class(Base), pointer :: pointerPolyField
end type
class(Base), allocatable :: baseVar1
type(Base) :: baseVar2
end module m1
subroutine s1()
! Test deallocation of polymorphic entities caused by block exit
use m1
block
! The following should not cause problems
integer :: outerInt
! The following are OK since they're not in a DO CONCURRENT
class(Base), allocatable :: outerAllocatablePolyVar
class(Base), allocatable, codimension[:] :: outerAllocatablePolyCoarray
type(HasAllocPolyType), allocatable :: outerAllocatableWithAllocPoly
type(HasAllocPolyCoarrayType), allocatable :: outerAllocWithAllocPolyCoarray
do concurrent (i = 1:10)
! The following should not cause problems
block
integer, allocatable :: blockInt
end block
block
! Test polymorphic entities
! OK because it's a pointer to a polymorphic entity
class(Base), pointer :: pointerPoly
! OK because it's not polymorphic
integer, allocatable :: intAllocatable
! OK because it's not polymorphic
type(Base), allocatable :: allocatableNonPolyBlockVar
! Bad because it's polymorphic and allocatable
class(Base), allocatable :: allocatablePoly
! OK because it has the SAVE attribute
class(Base), allocatable, save :: allocatablePolySave
! Bad because it's polymorphic and allocatable
class(Base), allocatable, codimension[:] :: allocatablePolyCoarray
! OK because it's not polymorphic and allocatable
type(Base), allocatable, codimension[:] :: allocatableCoarray
! Bad because it has a allocatable polymorphic component
type(HasAllocPolyType), allocatable :: allocatableWithAllocPoly
! OK because the declared variable is not allocatable
type(HasAllocPolyType) :: nonAllocatableWithAllocPoly
! OK because the declared variable is not allocatable
type(HasAllocPolyCoarrayType) :: nonAllocatableWithAllocPolyCoarray
! Bad because even though the declared the allocatable component is a coarray
type(HasAllocPolyCoarrayType), allocatable :: allocWithAllocPolyCoarray
! OK since it has no polymorphic component
type(HasAllocCoarrayType) :: nonAllocWithAllocCoarray
! OK since it has no component that's polymorphic, oops
type(HasPointerPolyType), allocatable :: allocatableWithPointerPoly
!ERROR: Deallocation of a polymorphic entity caused by block exit not allowed in DO CONCURRENT
!ERROR: Deallocation of a polymorphic entity caused by block exit not allowed in DO CONCURRENT
!ERROR: Deallocation of a polymorphic entity caused by block exit not allowed in DO CONCURRENT
!ERROR: Deallocation of a polymorphic entity caused by block exit not allowed in DO CONCURRENT
end block
end do
end block
end subroutine s1
subroutine s2()
! Test deallocation of a polymorphic entity cause by intrinsic assignment
use m1
class(Base), allocatable :: localVar
class(Base), allocatable :: localVar1
type(Base), allocatable :: localVar2
type(HasAllocPolyType), allocatable :: polyComponentVar
type(HasAllocPolyType), allocatable :: polyComponentVar1
type(HasAllocPolyType) :: nonAllocPolyComponentVar
type(HasAllocPolyType) :: nonAllocPolyComponentVar1
class(HasAllocPolyCoarrayType), allocatable :: allocPolyCoarray
class(HasAllocPolyCoarrayType), allocatable :: allocPolyCoarray1
class(Base), allocatable, codimension[:] :: allocPolyComponentVar
class(Base), allocatable, codimension[:] :: allocPolyComponentVar1
allocate(ChildType :: localVar)
allocate(ChildType :: localVar1)
allocate(Base :: localVar2)
allocate(polyComponentVar)
allocate(polyComponentVar1)
allocate(allocPolyCoarray)
allocate(allocPolyCoarray1)
! These are OK because they're not in a DO CONCURRENT
localVar = localVar1
nonAllocPolyComponentVar = nonAllocPolyComponentVar1
polyComponentVar = polyComponentVar1
allocPolyCoarray = allocPolyCoarray1
do concurrent (i = 1:10)
! Test polymorphic entities
! Bad because localVar is allocatable and polymorphic, 10.2.1.3, par. 3
!ERROR: Deallocation of a polymorphic entity caused by assignment not allowed in DO CONCURRENT
localVar = localVar1
! The next one should be OK since localVar2 is not polymorphic
localVar2 = localVar1
! Bad because the copying of the components causes deallocation
!ERROR: Deallocation of a polymorphic entity caused by assignment not allowed in DO CONCURRENT
nonAllocPolyComponentVar = nonAllocPolyComponentVar1
! Bad because possible deallocation a variable with a polymorphic component
!ERROR: Deallocation of a polymorphic entity caused by assignment not allowed in DO CONCURRENT
polyComponentVar = polyComponentVar1
! Bad because deallocation upon assignment happens with allocatable
! entities, even if they're coarrays. The noncoarray restriction only
! applies to components
!ERROR: Deallocation of a polymorphic entity caused by assignment not allowed in DO CONCURRENT
allocPolyCoarray = allocPolyCoarray1
end do
end subroutine s2
subroutine s3()
! Test direct deallocation
use m1
class(Base), allocatable :: polyVar
type(Base), allocatable :: nonPolyVar
type(HasAllocPolyType), allocatable :: polyComponentVar
type(HasAllocPolyType), pointer :: pointerPolyComponentVar
allocate(ChildType:: polyVar)
allocate(nonPolyVar)
allocate(polyComponentVar)
allocate(pointerPolyComponentVar)
! These are all good because they're not in a do concurrent
deallocate(polyVar)
allocate(polyVar)
deallocate(polyComponentVar)
allocate(polyComponentVar)
deallocate(pointerPolyComponentVar)
allocate(pointerPolyComponentVar)
do concurrent (i = 1:10)
! Bad because deallocation of a polymorphic entity
!ERROR: Deallocation of a polymorphic entity not allowed in DO CONCURRENT
deallocate(polyVar)
! Bad, deallocation of an entity with a polymorphic component
!ERROR: Deallocation of a polymorphic entity not allowed in DO CONCURRENT
deallocate(polyComponentVar)
! Bad, deallocation of a pointer to an entity with a polymorphic component
!ERROR: Deallocation of a polymorphic entity not allowed in DO CONCURRENT
deallocate(pointerPolyComponentVar)
! Deallocation of a nonpolymorphic entity
deallocate(nonPolyVar)
end do
end subroutine s3

12
flang/test/semantics/dosemantics05.f90
View File

@ -62,22 +62,22 @@ subroutine s1()
associate (avar => ivar)
do concurrent (i = 1:2:0) default(none) shared(jvar) local(kvar)
!ERROR: Variable 'ivar' from an enclosing scope referenced in a DO CONCURRENT with DEFAULT(NONE) must appear in a locality-spec
!ERROR: Variable 'ivar' from an enclosing scope referenced in DO CONCURRENT with DEFAULT(NONE) must appear in a locality-spec
ivar = &
!ERROR: Variable 'ivar' from an enclosing scope referenced in a DO CONCURRENT with DEFAULT(NONE) must appear in a locality-spec
!ERROR: Variable 'ivar' from an enclosing scope referenced in DO CONCURRENT with DEFAULT(NONE) must appear in a locality-spec
ivar + i
block
real :: bvar
!ERROR: Variable 'avar' from an enclosing scope referenced in a DO CONCURRENT with DEFAULT(NONE) must appear in a locality-spec
!ERROR: Variable 'avar' from an enclosing scope referenced in DO CONCURRENT with DEFAULT(NONE) must appear in a locality-spec
avar = 4
!ERROR: Variable 'x' from an enclosing scope referenced in a DO CONCURRENT with DEFAULT(NONE) must appear in a locality-spec
!ERROR: Variable 'x' from an enclosing scope referenced in DO CONCURRENT with DEFAULT(NONE) must appear in a locality-spec
x = 3.5
bvar = 3.5 + i ! OK, bvar's scope is within the DO CONCURRENT
end block
jvar = 5 ! OK, jvar appears in a locality spec
kvar = 5 ! OK, kvar appears in a locality spec
!ERROR: Variable 'mvar' from an enclosing scope referenced in a DO CONCURRENT with DEFAULT(NONE) must appear in a locality-spec
!ERROR: Variable 'mvar' from an enclosing scope referenced in DO CONCURRENT with DEFAULT(NONE) must appear in a locality-spec
mvar = 3.5
end do
end associate
@ -93,7 +93,7 @@ subroutine s1()
select type ( a => p_or_c )
type is ( point )
do concurrent (i=1:5) default (none)
!ERROR: Variable 'a' from an enclosing scope referenced in a DO CONCURRENT with DEFAULT(NONE) must appear in a locality-spec
!ERROR: Variable 'a' from an enclosing scope referenced in DO CONCURRENT with DEFAULT(NONE) must appear in a locality-spec
a%x = 3.5
end do
end select