[flang-commits] [flang] 2c8cb9a - [flang] Handle common block with different sizes in same file
Jean Perier via flang-commits
flang-commits at lists.llvm.org
Fri Apr 29 05:53:17 PDT 2022
Author: Jean Perier
Date: 2022-04-29T14:52:47+02:00
New Revision: 2c8cb9acb51e2fa74bf9339ddd0884ef9d921dfc
URL: https://github.com/llvm/llvm-project/commit/2c8cb9acb51e2fa74bf9339ddd0884ef9d921dfc
DIFF: https://github.com/llvm/llvm-project/commit/2c8cb9acb51e2fa74bf9339ddd0884ef9d921dfc.diff
LOG: [flang] Handle common block with different sizes in same file
Semantics is not preventing a named common block to appear with
different size in a same file (named common block should always have
the same storage size (see Fortran 2018 8.10.2.5), but it is a common
extension to accept different sizes).
Lowering was not coping with this well, since it just use the first
common block appearance, starting with BLOCK DATAs to define common
blocks (this also was an issue with the blank common block, which can
legally appear with different size in different scoping units).
Semantics is also not preventing named common from being initialized
outside of a BLOCK DATA, and lowering was dealing badly with this,
since it only gave an initial value to common blocks Globals if the
first common block appearance, starting with BLOCK DATAs had an initial
value.
Semantics is also allowing blank common to be initialized, while
lowering was assuming this would never happen, and was never creating
an initial value for it.
Lastly, semantics was not complaining if a COMMON block was initialized
in several scoping unit in a same file, while lowering can only generate
one of these initial value.
To fix this, add a structure to keep track of COMMON block properties
(biggest size, and initial value if any) at the Program level. Once the
size of a common block appearance is know, the common block appearance
is checked against this information. It allows semantics to emit an error
in case of multiple initialization in different scopes of a same common
block, and to warn in case named common blocks appears with different
sizes. Lastly, this allows lowering to use the Program level info about
common blocks to emit the right GlobalOp for a Common Block, regardless
of the COMMON Block appearances order: It emits a GlobalOp with the
biggest size, whose lowest bytes are initialized with the initial value
if any is given in a scope where the common block appears.
Lowering is updated to go emit the common blocks before anything else so
that the related GlobalOps are available when lowering the scopes where
common block appear. It is also updated to not assume that blank common
are never initialized.
Differential Revision: https://reviews.llvm.org/D124622
Added:
flang/test/Lower/common-block-2.f90
flang/test/Semantics/common-blocks-warn.f90
flang/test/Semantics/common-blocks.f90
Modified:
flang/docs/Extensions.md
flang/include/flang/Lower/ConvertVariable.h
flang/include/flang/Lower/PFTBuilder.h
flang/include/flang/Semantics/semantics.h
flang/lib/Lower/Bridge.cpp
flang/lib/Lower/ConvertVariable.cpp
flang/lib/Lower/PFTBuilder.cpp
flang/lib/Semantics/compute-offsets.cpp
flang/lib/Semantics/semantics.cpp
flang/test/Lower/common-block.f90
flang/test/Lower/module_definition.f90
flang/test/Lower/module_use.f90
flang/test/Lower/pointer-initial-target-2.f90
flang/test/Semantics/resolve42.f90
Removed:
################################################################################
diff --git a/flang/docs/Extensions.md b/flang/docs/Extensions.md
index e25331c85a21a..568a222bde72d 100644
--- a/flang/docs/Extensions.md
+++ b/flang/docs/Extensions.md
@@ -206,6 +206,7 @@ end
* External unit 0 is predefined and connected to the standard error output,
and defined as `ERROR_UNIT` in the intrinsic `ISO_FORTRAN_ENV` module.
* Objects in blank COMMON may be initialized.
+* Initialization of COMMON blocks outside of BLOCK DATA subprograms.
* Multiple specifications of the SAVE attribute on the same object
are allowed, with a warning.
* Specific intrinsic functions BABS, IIABS, JIABS, KIABS, ZABS, and CDABS.
diff --git a/flang/include/flang/Lower/ConvertVariable.h b/flang/include/flang/Lower/ConvertVariable.h
index 6b439f4e6d141..887c3bf9a184f 100644
--- a/flang/include/flang/Lower/ConvertVariable.h
+++ b/flang/include/flang/Lower/ConvertVariable.h
@@ -54,6 +54,14 @@ void instantiateVariable(AbstractConverter &, const pft::Variable &var,
/// called.
void defineModuleVariable(AbstractConverter &, const pft::Variable &var);
+/// Create fir::GlobalOp for all common blocks, including their initial values
+/// if they have one. This should be called before lowering any scopes so that
+/// common block globals are available when a common appear in a scope.
+void defineCommonBlocks(
+ AbstractConverter &,
+ const std::vector<std::pair<semantics::SymbolRef, std::size_t>>
+ &commonBlocks);
+
/// Lower a symbol attributes given an optional storage \p and add it to the
/// provided symbol map. If \preAlloc is not provided, a temporary storage will
/// be allocated. This is a low level function that should only be used if
diff --git a/flang/include/flang/Lower/PFTBuilder.h b/flang/include/flang/Lower/PFTBuilder.h
index 1d4788451a42c..0c9aba6d2e2f2 100644
--- a/flang/include/flang/Lower/PFTBuilder.h
+++ b/flang/include/flang/Lower/PFTBuilder.h
@@ -24,6 +24,7 @@
#include "flang/Parser/parse-tree.h"
#include "flang/Semantics/attr.h"
#include "flang/Semantics/scope.h"
+#include "flang/Semantics/semantics.h"
#include "flang/Semantics/symbol.h"
#include "llvm/Support/ErrorHandling.h"
#include "llvm/Support/raw_ostream.h"
@@ -737,18 +738,23 @@ struct Program {
using Units = std::variant<FunctionLikeUnit, ModuleLikeUnit, BlockDataUnit,
CompilerDirectiveUnit>;
- Program() = default;
+ Program(semantics::CommonBlockList &&commonBlocks)
+ : commonBlocks{std::move(commonBlocks)} {}
Program(Program &&) = default;
Program(const Program &) = delete;
const std::list<Units> &getUnits() const { return units; }
std::list<Units> &getUnits() { return units; }
+ const semantics::CommonBlockList &getCommonBlocks() const {
+ return commonBlocks;
+ }
/// LLVM dump method on a Program.
LLVM_DUMP_METHOD void dump() const;
private:
std::list<Units> units;
+ semantics::CommonBlockList commonBlocks;
};
/// Return the list of variables that appears in the specification expressions
diff --git a/flang/include/flang/Semantics/semantics.h b/flang/include/flang/Semantics/semantics.h
index b64420eb20e4a..bb96099dee4d0 100644
--- a/flang/include/flang/Semantics/semantics.h
+++ b/flang/include/flang/Semantics/semantics.h
@@ -49,6 +49,8 @@ struct WhereConstruct;
namespace Fortran::semantics {
class Symbol;
+class CommonBlockMap;
+using CommonBlockList = std::vector<std::pair<SymbolRef, std::size_t>>;
using ConstructNode = std::variant<const parser::AssociateConstruct *,
const parser::BlockConstruct *, const parser::CaseConstruct *,
@@ -199,6 +201,30 @@ class SemanticsContext {
// during semantics.
parser::Program &SaveParseTree(parser::Program &&);
+ // Ensures a common block definition does not conflict with previous
+ // appearances in the program and consolidate information about
+ // common blocks at the program level for later checks and lowering.
+ // This can obviously not check any conflicts between
diff erent compilation
+ // units (in case such conflicts exist, the behavior will depend on the
+ // linker).
+ void MapCommonBlockAndCheckConflicts(const Symbol &);
+
+ // Get the list of common blocks appearing in the program. If a common block
+ // appears in several subprograms, only one of its appearance is returned in
+ // the list alongside the biggest byte size of all its appearances.
+ // If a common block is initialized in any of its appearances, the list will
+ // contain the appearance with the initialization, otherwise the appearance
+ // with the biggest size is returned. The extra byte size information allows
+ // handling the case where the common block initialization is not the
+ // appearance with the biggest size: the common block will have the biggest
+ // size with the first bytes initialized with the initial value. This is not
+ // standard, if the initialization and biggest size appearances are in
+ //
diff erent compilation units, the behavior will depend on the linker. The
+ // linker may have the behavior described before, but it may also keep the
+ // initialized common symbol without extending its size, or have some other
+ // behavior.
+ CommonBlockList GetCommonBlocks() const;
+
private:
void CheckIndexVarRedefine(
const parser::CharBlock &, const Symbol &, parser::MessageFixedText &&);
@@ -231,6 +257,7 @@ class SemanticsContext {
std::set<std::string> tempNames_;
const Scope *builtinsScope_{nullptr}; // module __Fortran_builtins
std::list<parser::Program> modFileParseTrees_;
+ std::unique_ptr<CommonBlockMap> commonBlockMap_;
};
class Semantics {
diff --git a/flang/lib/Lower/Bridge.cpp b/flang/lib/Lower/Bridge.cpp
index dc4ee10767fef..662bb69d517f5 100644
--- a/flang/lib/Lower/Bridge.cpp
+++ b/flang/lib/Lower/Bridge.cpp
@@ -178,29 +178,35 @@ class FirConverter : public Fortran::lower::AbstractConverter {
/// Convert the PFT to FIR.
void run(Fortran::lower::pft::Program &pft) {
// Preliminary translation pass.
+
+ // - Lower common blocks from the PFT common block list that contains a
+ // consolidated list of the common blocks (with the initialization if any in
+ // the Program, and with the common block biggest size in all its
+ // appearance). This is done before lowering any scope declarations because
+ // it is not know at the local scope level what MLIR type common blocks
+ // should have to suit all its usage in the compilation unit.
+ lowerCommonBlocks(pft.getCommonBlocks());
+
// - Declare all functions that have definitions so that definition
// signatures prevail over call site signatures.
// - Define module variables and OpenMP/OpenACC declarative construct so
// that they are available before lowering any function that may use
// them.
- // - Translate block data programs so that common block definitions with
- // data initializations take precedence over other definitions.
for (Fortran::lower::pft::Program::Units &u : pft.getUnits()) {
- std::visit(
- Fortran::common::visitors{
- [&](Fortran::lower::pft::FunctionLikeUnit &f) {
- declareFunction(f);
- },
- [&](Fortran::lower::pft::ModuleLikeUnit &m) {
- lowerModuleDeclScope(m);
- for (Fortran::lower::pft::FunctionLikeUnit &f :
- m.nestedFunctions)
- declareFunction(f);
- },
- [&](Fortran::lower::pft::BlockDataUnit &b) { lowerBlockData(b); },
- [&](Fortran::lower::pft::CompilerDirectiveUnit &d) {},
- },
- u);
+ std::visit(Fortran::common::visitors{
+ [&](Fortran::lower::pft::FunctionLikeUnit &f) {
+ declareFunction(f);
+ },
+ [&](Fortran::lower::pft::ModuleLikeUnit &m) {
+ lowerModuleDeclScope(m);
+ for (Fortran::lower::pft::FunctionLikeUnit &f :
+ m.nestedFunctions)
+ declareFunction(f);
+ },
+ [&](Fortran::lower::pft::BlockDataUnit &b) {},
+ [&](Fortran::lower::pft::CompilerDirectiveUnit &d) {},
+ },
+ u);
}
// Primary translation pass.
@@ -2562,6 +2568,13 @@ class FirConverter : public Fortran::lower::AbstractConverter {
});
}
+ /// Create fir::Global for all the common blocks that appear in the program.
+ void
+ lowerCommonBlocks(const Fortran::semantics::CommonBlockList &commonBlocks) {
+ createGlobalOutsideOfFunctionLowering(
+ [&]() { Fortran::lower::defineCommonBlocks(*this, commonBlocks); });
+ }
+
/// Lower a procedure (nest).
void lowerFunc(Fortran::lower::pft::FunctionLikeUnit &funit) {
if (!funit.isMainProgram()) {
diff --git a/flang/lib/Lower/ConvertVariable.cpp b/flang/lib/Lower/ConvertVariable.cpp
index 87ed2286f7630..6c0df49a56e51 100644
--- a/flang/lib/Lower/ConvertVariable.cpp
+++ b/flang/lib/Lower/ConvertVariable.cpp
@@ -882,47 +882,82 @@ getCommonMembersWithInitAliases(const Fortran::semantics::Symbol &common) {
return members;
}
-/// Define a global for a common block if it does not already exist in the
-/// mlir module.
-/// There is no "declare" version since there is not a
-/// scope that owns common blocks more that the others. All scopes using
-/// a common block attempts to define it with common linkage.
+/// Return the fir::GlobalOp that was created of COMMON block \p common.
+/// It is an error if the fir::GlobalOp was not created before this is
+/// called (it cannot be created on the flight because it is not known here
+/// what mlir type the GlobalOp should have to satisfy all the
+/// appearances in the program).
static fir::GlobalOp
-defineCommonBlock(Fortran::lower::AbstractConverter &converter,
- const Fortran::semantics::Symbol &common) {
+getCommonBlockGlobal(Fortran::lower::AbstractConverter &converter,
+ const Fortran::semantics::Symbol &common) {
+ fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+ std::string commonName = Fortran::lower::mangle::mangleName(common);
+ fir::GlobalOp global = builder.getNamedGlobal(commonName);
+ // Common blocks are lowered before any subprograms to deal with common
+ // whose size may not be the same in every subprograms.
+ if (!global)
+ fir::emitFatalError(converter.genLocation(common.name()),
+ "COMMON block was not lowered before its usage");
+ return global;
+}
+
+/// Create the fir::GlobalOp for COMMON block \p common. If \p common has an
+/// initial value, it is not created yet. Instead, the common block list
+/// members is returned to later create the initial value in
+/// finalizeCommonBlockDefinition.
+static std::optional<std::tuple<
+ fir::GlobalOp, Fortran::semantics::MutableSymbolVector, mlir::Location>>
+declareCommonBlock(Fortran::lower::AbstractConverter &converter,
+ const Fortran::semantics::Symbol &common,
+ std::size_t commonSize) {
fir::FirOpBuilder &builder = converter.getFirOpBuilder();
std::string commonName = Fortran::lower::mangle::mangleName(common);
fir::GlobalOp global = builder.getNamedGlobal(commonName);
if (global)
- return global;
+ return std::nullopt;
Fortran::semantics::MutableSymbolVector cmnBlkMems =
getCommonMembersWithInitAliases(common);
mlir::Location loc = converter.genLocation(common.name());
- mlir::IndexType idxTy = builder.getIndexType();
mlir::StringAttr linkage = builder.createCommonLinkage();
- if (!common.name().size() || !commonBlockHasInit(cmnBlkMems)) {
- // A blank (anonymous) COMMON block must always be initialized to zero.
- // A named COMMON block sans initializers is also initialized to zero.
+ if (!commonBlockHasInit(cmnBlkMems)) {
+ // A COMMON block sans initializers is initialized to zero.
// mlir::Vector types must have a strictly positive size, so at least
// temporarily, force a zero size COMMON block to have one byte.
- const auto sz = static_cast<fir::SequenceType::Extent>(
- common.size() > 0 ? common.size() : 1);
+ const auto sz =
+ static_cast<fir::SequenceType::Extent>(commonSize > 0 ? commonSize : 1);
fir::SequenceType::Shape shape = {sz};
mlir::IntegerType i8Ty = builder.getIntegerType(8);
auto commonTy = fir::SequenceType::get(shape, i8Ty);
auto vecTy = mlir::VectorType::get(sz, i8Ty);
mlir::Attribute zero = builder.getIntegerAttr(i8Ty, 0);
auto init = mlir::DenseElementsAttr::get(vecTy, llvm::makeArrayRef(zero));
- return builder.createGlobal(loc, commonTy, commonName, linkage, init);
+ builder.createGlobal(loc, commonTy, commonName, linkage, init);
+ // No need to add any initial value later.
+ return std::nullopt;
}
-
- // Named common with initializer, sort members by offset before generating
- // the type and initializer.
+ // COMMON block with initializer (note that initialized blank common are
+ // accepted as an extension by semantics). Sort members by offset before
+ // generating the type and initializer.
std::sort(cmnBlkMems.begin(), cmnBlkMems.end(),
[](auto &s1, auto &s2) { return s1->offset() < s2->offset(); });
mlir::TupleType commonTy =
- getTypeOfCommonWithInit(converter, cmnBlkMems, common.size());
+ getTypeOfCommonWithInit(converter, cmnBlkMems, commonSize);
+ // Create the global object, the initial value will be added later.
+ global = builder.createGlobal(loc, commonTy, commonName);
+ return std::make_tuple(global, std::move(cmnBlkMems), loc);
+}
+
+/// Add initial value to a COMMON block fir::GlobalOp \p global given the list
+/// \p cmnBlkMems of the common block member symbols that contains symbols with
+/// an initial value.
+static void finalizeCommonBlockDefinition(
+ mlir::Location loc, Fortran::lower::AbstractConverter &converter,
+ fir::GlobalOp global,
+ const Fortran::semantics::MutableSymbolVector &cmnBlkMems) {
+ fir::FirOpBuilder &builder = converter.getFirOpBuilder();
+ mlir::TupleType commonTy = global.getType().cast<mlir::TupleType>();
auto initFunc = [&](fir::FirOpBuilder &builder) {
+ mlir::IndexType idxTy = builder.getIndexType();
mlir::Value cb = builder.create<fir::UndefOp>(loc, commonTy);
unsigned tupIdx = 0;
std::size_t offset = 0;
@@ -957,10 +992,25 @@ defineCommonBlock(Fortran::lower::AbstractConverter &converter,
LLVM_DEBUG(llvm::dbgs() << "}\n");
builder.create<fir::HasValueOp>(loc, cb);
};
- // create the global object
- return builder.createGlobal(loc, commonTy, commonName,
- /*isConstant=*/false, initFunc);
+ createGlobalInitialization(builder, global, initFunc);
}
+
+void Fortran::lower::defineCommonBlocks(
+ Fortran::lower::AbstractConverter &converter,
+ const Fortran::semantics::CommonBlockList &commonBlocks) {
+ // Common blocks may depend on another common block address (if they contain
+ // pointers with initial targets). To cover this case, create all common block
+ // fir::Global before creating the initial values (if any).
+ std::vector<std::tuple<fir::GlobalOp, Fortran::semantics::MutableSymbolVector,
+ mlir::Location>>
+ delayedInitializations;
+ for (const auto [common, size] : commonBlocks)
+ if (auto delayedInit = declareCommonBlock(converter, common, size))
+ delayedInitializations.emplace_back(std::move(*delayedInit));
+ for (auto &[global, cmnBlkMems, loc] : delayedInitializations)
+ finalizeCommonBlockDefinition(loc, converter, global, cmnBlkMems);
+}
+
/// The COMMON block is a global structure. `var` will be at some offset
/// within the COMMON block. Adds the address of `var` (COMMON + offset) to
/// the symbol map.
@@ -977,7 +1027,7 @@ static void instantiateCommon(Fortran::lower::AbstractConverter &converter,
commonAddr = symBox.getAddr();
if (!commonAddr) {
// introduce a local AddrOf and add it to the map
- fir::GlobalOp global = defineCommonBlock(converter, common);
+ fir::GlobalOp global = getCommonBlockGlobal(converter, common);
commonAddr = builder.create<fir::AddrOfOp>(loc, global.resultType(),
global.getSymbol());
@@ -1761,8 +1811,9 @@ void Fortran::lower::defineModuleVariable(
const Fortran::semantics::Symbol &sym = var.getSymbol();
if (const Fortran::semantics::Symbol *common =
Fortran::semantics::FindCommonBlockContaining(var.getSymbol())) {
- // Define common block containing the variable.
- defineCommonBlock(converter, *common);
+ // Nothing to do, common block are generated before everything. Ensure
+ // this was done by calling getCommonBlockGlobal.
+ getCommonBlockGlobal(converter, *common);
} else if (var.isAlias()) {
// Do nothing. Mapping will be done on user side.
} else {
diff --git a/flang/lib/Lower/PFTBuilder.cpp b/flang/lib/Lower/PFTBuilder.cpp
index 478ca19f72111..3be7ebedb3da6 100644
--- a/flang/lib/Lower/PFTBuilder.cpp
+++ b/flang/lib/Lower/PFTBuilder.cpp
@@ -76,8 +76,9 @@ struct UnwrapStmt<parser::UnlabeledStatement<A>> {
class PFTBuilder {
public:
PFTBuilder(const semantics::SemanticsContext &semanticsContext)
- : pgm{std::make_unique<lower::pft::Program>()}, semanticsContext{
- semanticsContext} {
+ : pgm{std::make_unique<lower::pft::Program>(
+ semanticsContext.GetCommonBlocks())},
+ semanticsContext{semanticsContext} {
lower::pft::PftNode pftRoot{*pgm.get()};
pftParentStack.push_back(pftRoot);
}
diff --git a/flang/lib/Semantics/compute-offsets.cpp b/flang/lib/Semantics/compute-offsets.cpp
index 5698ef4690ddb..82b4eeff390a3 100644
--- a/flang/lib/Semantics/compute-offsets.cpp
+++ b/flang/lib/Semantics/compute-offsets.cpp
@@ -200,6 +200,7 @@ void ComputeOffsetsHelper::DoCommonBlock(Symbol &commonBlock) {
}
commonBlock.set_size(std::max(minSize, offset_));
details.set_alignment(std::max(minAlignment, alignment_));
+ context_.MapCommonBlockAndCheckConflicts(commonBlock);
}
void ComputeOffsetsHelper::DoEquivalenceBlockBase(
diff --git a/flang/lib/Semantics/semantics.cpp b/flang/lib/Semantics/semantics.cpp
index 95bbd10e2e7a3..c409bb59ee061 100644
--- a/flang/lib/Semantics/semantics.cpp
+++ b/flang/lib/Semantics/semantics.cpp
@@ -178,6 +178,109 @@ static bool PerformStatementSemantics(
return !context.AnyFatalError();
}
+/// This class keeps track of the common block appearances with the biggest size
+/// and with an initial value (if any) in a program. This allows reporting
+/// conflicting initialization and warning about appearances of a same
+/// named common block with
diff erent sizes. The biggest common block size and
+/// initialization (if any) can later be provided so that lowering can generate
+/// the correct symbol size and initial values, even when named common blocks
+/// appears with
diff erent sizes and are initialized outside of block data.
+class CommonBlockMap {
+private:
+ struct CommonBlockInfo {
+ // Common block symbol for the appearance with the biggest size.
+ SymbolRef biggestSize;
+ // Common block symbol for the appearance with the initialized members (if
+ // any).
+ std::optional<SymbolRef> initialization;
+ };
+
+public:
+ void MapCommonBlockAndCheckConflicts(
+ SemanticsContext &context, const Symbol &common) {
+ const Symbol *isInitialized{CommonBlockIsInitialized(common)};
+ auto [it, firstAppearance] = commonBlocks_.insert({common.name(),
+ isInitialized ? CommonBlockInfo{common, common}
+ : CommonBlockInfo{common, std::nullopt}});
+ if (!firstAppearance) {
+ CommonBlockInfo &info{it->second};
+ if (isInitialized) {
+ if (info.initialization.has_value() &&
+ &**info.initialization != &common) {
+ // Use the location of the initialization in the error message because
+ // common block symbols may have no location if they are blank
+ // commons.
+ const Symbol &previousInit{
+ DEREF(CommonBlockIsInitialized(**info.initialization))};
+ context
+ .Say(isInitialized->name(),
+ "Multiple initialization of COMMON block /%s/"_err_en_US,
+ common.name())
+ .Attach(previousInit.name(),
+ "Previous initialization of COMMON block /%s/"_en_US,
+ common.name());
+ } else {
+ info.initialization = common;
+ }
+ }
+ if (common.size() != info.biggestSize->size() && !common.name().empty()) {
+ context
+ .Say(common.name(),
+ "A named COMMON block should have the same size everywhere it appears (%zd bytes here)"_port_en_US,
+ common.size())
+ .Attach(info.biggestSize->name(),
+ "Previously defined with a size of %zd bytes"_en_US,
+ info.biggestSize->size());
+ }
+ if (common.size() > info.biggestSize->size()) {
+ info.biggestSize = common;
+ }
+ }
+ }
+
+ CommonBlockList GetCommonBlocks() const {
+ CommonBlockList result;
+ for (const auto &[_, blockInfo] : commonBlocks_) {
+ result.emplace_back(
+ std::make_pair(blockInfo.initialization ? *blockInfo.initialization
+ : blockInfo.biggestSize,
+ blockInfo.biggestSize->size()));
+ }
+ return result;
+ }
+
+private:
+ /// Return the symbol of an initialized member if a COMMON block
+ /// is initalized. Otherwise, return nullptr.
+ static Symbol *CommonBlockIsInitialized(const Symbol &common) {
+ const auto &commonDetails =
+ common.get<Fortran::semantics::CommonBlockDetails>();
+
+ for (const auto &member : commonDetails.objects()) {
+ if (IsInitialized(*member)) {
+ return &*member;
+ }
+ }
+
+ // Common block may be initialized via initialized variables that are in an
+ // equivalence with the common block members.
+ for (const Fortran::semantics::EquivalenceSet &set :
+ common.owner().equivalenceSets()) {
+ for (const Fortran::semantics::EquivalenceObject &obj : set) {
+ if (!obj.symbol.test(
+ Fortran::semantics::Symbol::Flag::CompilerCreated)) {
+ if (FindCommonBlockContaining(obj.symbol) == &common &&
+ IsInitialized(obj.symbol)) {
+ return &obj.symbol;
+ }
+ }
+ }
+ }
+ return nullptr;
+ }
+ std::map<SourceName, CommonBlockInfo> commonBlocks_;
+};
+
SemanticsContext::SemanticsContext(
const common::IntrinsicTypeDefaultKinds &defaultKinds,
const common::LanguageFeatureControl &languageFeatures,
@@ -469,4 +572,19 @@ static void PutIndent(llvm::raw_ostream &os, int indent) {
os << " ";
}
}
+
+void SemanticsContext::MapCommonBlockAndCheckConflicts(const Symbol &common) {
+ if (!commonBlockMap_) {
+ commonBlockMap_ = std::make_unique<CommonBlockMap>();
+ }
+ commonBlockMap_->MapCommonBlockAndCheckConflicts(*this, common);
+}
+
+CommonBlockList SemanticsContext::GetCommonBlocks() const {
+ if (commonBlockMap_) {
+ return commonBlockMap_->GetCommonBlocks();
+ }
+ return {};
+}
+
} // namespace Fortran::semantics
diff --git a/flang/test/Lower/common-block-2.f90 b/flang/test/Lower/common-block-2.f90
new file mode 100644
index 0000000000000..937b92e3d933f
--- /dev/null
+++ b/flang/test/Lower/common-block-2.f90
@@ -0,0 +1,37 @@
+! RUN: bbc %s -o - | FileCheck %s
+
+! Test support of non standard features regarding common blocks:
+! - A named common that appears with
diff erent storage sizes
+! - A blank common that is initialized
+! - A common block that is initialized outside of a BLOCK DATA.
+
+! CHECK-LABEL: fir.global @_QB : tuple<i32, !fir.array<8xi8>> {
+! CHECK: %[[undef:.*]] = fir.undefined tuple<i32, !fir.array<8xi8>>
+! CHECK: %[[init:.*]] = fir.insert_value %[[undef]], %c42{{.*}}, [0 : index] : (tuple<i32, !fir.array<8xi8>>, i32) -> tuple<i32, !fir.array<8xi8>>
+! CHECK: fir.has_value %[[init]] : tuple<i32, !fir.array<8xi8>>
+
+! CHECK-LABEL: fir.global @_QBa : tuple<i32, !fir.array<8xi8>> {
+! CHECK: %[[undef:.*]] = fir.undefined tuple<i32, !fir.array<8xi8>>
+! CHECK: %[[init:.*]] = fir.insert_value %[[undef]], %c42{{.*}}, [0 : index] : (tuple<i32, !fir.array<8xi8>>, i32) -> tuple<i32, !fir.array<8xi8>>
+! CHECK: fir.has_value %[[init]] : tuple<i32, !fir.array<8xi8>>
+
+
+subroutine first_appearance
+ real :: x, y, xa, ya
+ common // x, y
+ common /a/ xa, ya
+ call foo(x, xa)
+end subroutine
+
+subroutine second_appearance
+ real :: x, y, z, xa, ya, za
+ common // x, y, z
+ common /a/ xa, ya, za
+ call foo(x, xa)
+end subroutine
+
+subroutine third_appearance
+ integer :: x = 42, xa = 42
+ common // x
+ common /a/ xa
+end subroutine
diff --git a/flang/test/Lower/common-block.f90 b/flang/test/Lower/common-block.f90
index 9a103eacc88ad..eed3125b71beb 100644
--- a/flang/test/Lower/common-block.f90
+++ b/flang/test/Lower/common-block.f90
@@ -1,11 +1,11 @@
! RUN: bbc %s -o - | tco | FileCheck %s
! CHECK: @_QB = common global [8 x i8] zeroinitializer
+! CHECK: @_QBrien = common global [1 x i8] zeroinitializer
+! CHECK: @_QBwith_empty_equiv = common global [8 x i8] zeroinitializer
! CHECK: @_QBx = global { float, float } { float 1.0{{.*}}, float 2.0{{.*}} }
! CHECK: @_QBy = common global [12 x i8] zeroinitializer
! CHECK: @_QBz = global { i32, [4 x i8], float } { i32 42, [4 x i8] undef, float 3.000000e+00 }
-! CHECK: @_QBrien = common global [1 x i8] zeroinitializer
-! CHECK: @_QBwith_empty_equiv = common global [8 x i8] zeroinitializer
! CHECK-LABEL: _QPs0
subroutine s0
diff --git a/flang/test/Lower/module_definition.f90 b/flang/test/Lower/module_definition.f90
index f2e9badec7e98..5acf645861212 100644
--- a/flang/test/Lower/module_definition.f90
+++ b/flang/test/Lower/module_definition.f90
@@ -3,6 +3,27 @@
! Test lowering of module that defines data that is otherwise not used
! in this file.
+! Module defines variable in common block without initializer
+module modCommonNoInit1
+ ! Module variable is in blank common
+ real :: x_blank
+ common // x_blank
+ ! Module variable is in named common, no init
+ real :: x_named1
+ common /named1/ x_named1
+end module
+! CHECK-LABEL: fir.global common @_QB(dense<0> : vector<4xi8>) : !fir.array<4xi8>
+! CHECK-LABEL: fir.global common @_QBnamed1(dense<0> : vector<4xi8>) : !fir.array<4xi8>
+
+! Module defines variable in common block with initialization
+module modCommonInit1
+ integer :: i_named2 = 42
+ common /named2/ i_named2
+end module
+! CHECK-LABEL: fir.global @_QBnamed2 : tuple<i32> {
+ ! CHECK: %[[init:.*]] = fir.insert_value %{{.*}}, %c42{{.*}}, [0 : index] : (tuple<i32>, i32) -> tuple<i32>
+ ! CHECK: fir.has_value %[[init]] : tuple<i32>
+
! Module m1 defines simple data
module m1
real :: x
@@ -29,27 +50,6 @@ module modEq1
! CHECK: %[[v3:.*]] = fir.insert_on_range %2, %c0{{.*}} from (5) to (9) : (!fir.array<10xi32>, i32) -> !fir.array<10xi32>
! CHECK: fir.has_value %[[v3]] : !fir.array<10xi32>
-! Module defines variable in common block without initializer
-module modCommonNoInit1
- ! Module variable is in blank common
- real :: x_blank
- common // x_blank
- ! Module variable is in named common, no init
- real :: x_named1
- common /named1/ x_named1
-end module
-! CHECK-LABEL: fir.global common @_QB(dense<0> : vector<4xi8>) : !fir.array<4xi8>
-! CHECK-LABEL: fir.global common @_QBnamed1(dense<0> : vector<4xi8>) : !fir.array<4xi8>
-
-! Module defines variable in common block with initialization
-module modCommonInit1
- integer :: i_named2 = 42
- common /named2/ i_named2
-end module
-! CHECK-LABEL: fir.global @_QBnamed2 : tuple<i32> {
- ! CHECK: %[[init:.*]] = fir.insert_value %{{.*}}, %c42{{.*}}, [0 : index] : (tuple<i32>, i32) -> tuple<i32>
- ! CHECK: fir.has_value %[[init]] : tuple<i32>
-
! Test defining two module variables whose initializers depend on each others
! addresses.
module global_init_depending_on_each_other_address
diff --git a/flang/test/Lower/module_use.f90 b/flang/test/Lower/module_use.f90
index 06064fb755a50..6188a0064ce4c 100644
--- a/flang/test/Lower/module_use.f90
+++ b/flang/test/Lower/module_use.f90
@@ -5,6 +5,10 @@
! The modules are defined in module_definition.f90
! The first runs ensures the module file is generated.
+! CHECK: fir.global common @_QB(dense<0> : vector<4xi8>) : !fir.array<4xi8>
+! CHECK-NEXT: fir.global common @_QBnamed1(dense<0> : vector<4xi8>) : !fir.array<4xi8>
+! CHECK-NEXT: fir.global common @_QBnamed2(dense<0> : vector<4xi8>) : !fir.array<4xi8>
+
! CHECK-LABEL: func @_QPm1use()
real function m1use()
use m1
@@ -37,6 +41,3 @@ real function modCommon1Use()
! CHECK-DAG: fir.global @_QMm1Ex : f32
! CHECK-DAG: fir.global @_QMm1Ey : !fir.array<100xi32>
-! CHECK-DAG: fir.global common @_QBnamed2(dense<0> : vector<4xi8>) : !fir.array<4xi8>
-! CHECK-DAG: fir.global common @_QB(dense<0> : vector<4xi8>) : !fir.array<4xi8>
-! CHECK-DAG: fir.global common @_QBnamed1(dense<0> : vector<4xi8>) : !fir.array<4xi8>
diff --git a/flang/test/Lower/pointer-initial-target-2.f90 b/flang/test/Lower/pointer-initial-target-2.f90
index c48ba5fa2c075..c49c298d6b7cc 100644
--- a/flang/test/Lower/pointer-initial-target-2.f90
+++ b/flang/test/Lower/pointer-initial-target-2.f90
@@ -5,33 +5,6 @@
! More complete tests regarding the initial data target expression
! are done in pointer-initial-target.f90.
-! Test pointer initial data target in modules
-module some_mod
- real, target :: x(100)
- real, pointer :: p(:) => x
-! CHECK-LABEL: fir.global @_QMsome_modEp : !fir.box<!fir.ptr<!fir.array<?xf32>>> {
- ! CHECK: %[[x:.*]] = fir.address_of(@_QMsome_modEx) : !fir.ref<!fir.array<100xf32>>
- ! CHECK: %[[shape:.*]] = fir.shape %c100{{.*}} : (index) -> !fir.shape<1>
- ! CHECK: %[[box:.*]] = fir.embox %[[x]](%[[shape]]) : (!fir.ref<!fir.array<100xf32>>, !fir.shape<1>) -> !fir.box<!fir.ptr<!fir.array<?xf32>>>
- ! CHECK: fir.has_value %[[box]] : !fir.box<!fir.ptr<!fir.array<?xf32>>>
-end module
-
-! Test initial data target in a common block
-module some_mod_2
- real, target :: x(100), y(10:209)
- common /com/ x, y
- save :: /com/
- real, pointer :: p(:) => y
-! CHECK-LABEL: fir.global @_QMsome_mod_2Ep : !fir.box<!fir.ptr<!fir.array<?xf32>>> {
- ! CHECK: %[[c:.*]] = fir.address_of(@_QBcom) : !fir.ref<!fir.array<1200xi8>>
- ! CHECK: %[[com:.*]] = fir.convert %[[c]] : (!fir.ref<!fir.array<1200xi8>>) -> !fir.ref<!fir.array<?xi8>>
- ! CHECK: %[[yRaw:.*]] = fir.coordinate_of %[[com]], %c400{{.*}} : (!fir.ref<!fir.array<?xi8>>, index) -> !fir.ref<i8>
- ! CHECK: %[[y:.*]] = fir.convert %[[yRaw]] : (!fir.ref<i8>) -> !fir.ref<!fir.array<200xf32>>
- ! CHECK: %[[shape:.*]] = fir.shape_shift %c10{{.*}}, %c200{{.*}} : (index, index) -> !fir.shapeshift<1>
- ! CHECK: %[[box:.*]] = fir.embox %[[y]](%[[shape]]) : (!fir.ref<!fir.array<200xf32>>, !fir.shapeshift<1>) -> !fir.box<!fir.ptr<!fir.array<?xf32>>>
- ! CHECK: fir.has_value %[[box]] : !fir.box<!fir.ptr<!fir.array<?xf32>>>
-end module
-
! Test pointer initial data target with pointer in common blocks
block data
real, pointer :: p
@@ -46,6 +19,21 @@ module some_mod_2
! CHECK: fir.has_value %[[a]] : tuple<!fir.box<!fir.ptr<f32>>>
end block data
+! Test two common depending on each others because of initial data
+! targets
+block data tied
+ real, target :: x1 = 42
+ real, target :: x2 = 43
+ real, pointer :: p1 => x2
+ real, pointer :: p2 => x1
+ common /c1/ x1, p1
+ common /c2/ x2, p2
+! CHECK-LABEL: fir.global @_QBc1 : tuple<f32, !fir.array<4xi8>, !fir.box<!fir.ptr<f32>>>
+ ! CHECK: fir.address_of(@_QBc2) : !fir.ref<tuple<f32, !fir.array<4xi8>, !fir.box<!fir.ptr<f32>>>>
+! CHECK-LABEL: fir.global @_QBc2 : tuple<f32, !fir.array<4xi8>, !fir.box<!fir.ptr<f32>>>
+ ! CHECK: fir.address_of(@_QBc1) : !fir.ref<tuple<f32, !fir.array<4xi8>, !fir.box<!fir.ptr<f32>>>>
+end block data
+
! Test pointer in a common with initial target in the same common.
block data snake
integer, target :: b = 42
@@ -63,17 +51,29 @@ block data snake
! CHECK: fir.has_value %[[tuple2]] : tuple<!fir.box<!fir.ptr<i32>>, i32>
end block data
-! Test two common depending on each others because of initial data
-! targets
-block data tied
- real, target :: x1 = 42
- real, target :: x2 = 43
- real, pointer :: p1 => x2
- real, pointer :: p2 => x1
- common /c1/ x1, p1
- common /c2/ x2, p2
-! CHECK-LABEL: fir.global @_QBc1 : tuple<f32, !fir.array<4xi8>, !fir.box<!fir.ptr<f32>>>
- ! CHECK: fir.address_of(@_QBc2) : !fir.ref<tuple<f32, !fir.array<4xi8>, !fir.box<!fir.ptr<f32>>>>
-! CHECK-LABEL: fir.global @_QBc2 : tuple<f32, !fir.array<4xi8>, !fir.box<!fir.ptr<f32>>>
- ! CHECK: fir.address_of(@_QBc1) : !fir.ref<tuple<f32, !fir.array<4xi8>, !fir.box<!fir.ptr<f32>>>>
-end block data
+! Test pointer initial data target in modules
+module some_mod
+ real, target :: x(100)
+ real, pointer :: p(:) => x
+! CHECK-LABEL: fir.global @_QMsome_modEp : !fir.box<!fir.ptr<!fir.array<?xf32>>> {
+ ! CHECK: %[[x:.*]] = fir.address_of(@_QMsome_modEx) : !fir.ref<!fir.array<100xf32>>
+ ! CHECK: %[[shape:.*]] = fir.shape %c100{{.*}} : (index) -> !fir.shape<1>
+ ! CHECK: %[[box:.*]] = fir.embox %[[x]](%[[shape]]) : (!fir.ref<!fir.array<100xf32>>, !fir.shape<1>) -> !fir.box<!fir.ptr<!fir.array<?xf32>>>
+ ! CHECK: fir.has_value %[[box]] : !fir.box<!fir.ptr<!fir.array<?xf32>>>
+end module
+
+! Test initial data target in a common block
+module some_mod_2
+ real, target :: x(100), y(10:209)
+ common /com/ x, y
+ save :: /com/
+ real, pointer :: p(:) => y
+! CHECK-LABEL: fir.global @_QMsome_mod_2Ep : !fir.box<!fir.ptr<!fir.array<?xf32>>> {
+ ! CHECK: %[[c:.*]] = fir.address_of(@_QBcom) : !fir.ref<!fir.array<1200xi8>>
+ ! CHECK: %[[com:.*]] = fir.convert %[[c]] : (!fir.ref<!fir.array<1200xi8>>) -> !fir.ref<!fir.array<?xi8>>
+ ! CHECK: %[[yRaw:.*]] = fir.coordinate_of %[[com]], %c400{{.*}} : (!fir.ref<!fir.array<?xi8>>, index) -> !fir.ref<i8>
+ ! CHECK: %[[y:.*]] = fir.convert %[[yRaw]] : (!fir.ref<i8>) -> !fir.ref<!fir.array<200xf32>>
+ ! CHECK: %[[shape:.*]] = fir.shape_shift %c10{{.*}}, %c200{{.*}} : (index, index) -> !fir.shapeshift<1>
+ ! CHECK: %[[box:.*]] = fir.embox %[[y]](%[[shape]]) : (!fir.ref<!fir.array<200xf32>>, !fir.shapeshift<1>) -> !fir.box<!fir.ptr<!fir.array<?xf32>>>
+ ! CHECK: fir.has_value %[[box]] : !fir.box<!fir.ptr<!fir.array<?xf32>>>
+end module
diff --git a/flang/test/Semantics/common-blocks-warn.f90 b/flang/test/Semantics/common-blocks-warn.f90
new file mode 100644
index 0000000000000..e4e486b64fb06
--- /dev/null
+++ b/flang/test/Semantics/common-blocks-warn.f90
@@ -0,0 +1,16 @@
+! RUN: %flang -fsyntax-only 2>&1 %s | FileCheck %s
+
+! Test that a warning is emitted when a named common block appears in
+! several scopes with a
diff erent storage size.
+
+subroutine size_1
+ common x, y
+ common /c/ xc, yc
+end subroutine
+
+subroutine size_2
+ ! OK, blank common size may always
diff er.
+ common x, y, z
+ !CHECK: portability: A named COMMON block should have the same size everywhere it appears (12 bytes here)
+ common /c/ xc, yc, zc
+end subroutine
diff --git a/flang/test/Semantics/common-blocks.f90 b/flang/test/Semantics/common-blocks.f90
new file mode 100644
index 0000000000000..fccd48d67ee33
--- /dev/null
+++ b/flang/test/Semantics/common-blocks.f90
@@ -0,0 +1,23 @@
+! RUN: %python %S/test_errors.py %s %flang_fc1
+
+! Test check that enforce that a common block is initialized
+! only once in a file.
+
+subroutine init_1
+ common x, y
+ common /a/ xa, ya
+ common /b/ xb, yb
+ !CHECK: portability: Blank COMMON object 'x' in a DATA statement is not standard
+ data x /42./, xa /42./, yb/42./
+end subroutine
+
+subroutine init_conflict
+ !ERROR: Multiple initialization of COMMON block //
+ common x, y
+ !ERROR: Multiple initialization of COMMON block /a/
+ common /a/ xa, ya
+ common /b/ xb, yb
+ equivalence (yb, yb_eq)
+ !ERROR: Multiple initialization of COMMON block /b/
+ data x /66./, xa /66./, yb_eq /66./
+end subroutine
diff --git a/flang/test/Semantics/resolve42.f90 b/flang/test/Semantics/resolve42.f90
index a807d80cd2316..975bbed8cb4d5 100644
--- a/flang/test/Semantics/resolve42.f90
+++ b/flang/test/Semantics/resolve42.f90
@@ -83,7 +83,7 @@ module m11
end type
type(t2) :: x2
!ERROR: Derived type variable 'x2' may not appear in a COMMON block due to ALLOCATABLE component
- common x2
+ common /c2/ x2
end
module m12
@@ -98,7 +98,7 @@ module m12
end type
type(t2) :: x2
!ERROR: Derived type variable 'x2' may not appear in a COMMON block due to component with default initialization
- common x2
+ common /c3/ x2
end
subroutine s13
More information about the flang-commits
mailing list