From 2c8cb9acb51e2fa74bf9339ddd0884ef9d921dfc Mon Sep 17 00:00:00 2001 From: Jean Perier Date: Fri, 29 Apr 2022 14:52:27 +0200 Subject: [PATCH] [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 --- flang/docs/Extensions.md | 1 + flang/include/flang/Lower/ConvertVariable.h | 8 ++ flang/include/flang/Lower/PFTBuilder.h | 8 +- flang/include/flang/Semantics/semantics.h | 27 ++++ flang/lib/Lower/Bridge.cpp | 47 ++++--- flang/lib/Lower/ConvertVariable.cpp | 101 +++++++++++---- flang/lib/Lower/PFTBuilder.cpp | 5 +- flang/lib/Semantics/compute-offsets.cpp | 1 + flang/lib/Semantics/semantics.cpp | 118 ++++++++++++++++++ flang/test/Lower/common-block-2.f90 | 37 ++++++ flang/test/Lower/common-block.f90 | 4 +- flang/test/Lower/module_definition.f90 | 42 +++---- flang/test/Lower/module_use.f90 | 7 +- flang/test/Lower/pointer-initial-target-2.f90 | 92 +++++++------- flang/test/Semantics/common-blocks-warn.f90 | 16 +++ flang/test/Semantics/common-blocks.f90 | 23 ++++ flang/test/Semantics/resolve42.f90 | 4 +- 17 files changed, 422 insertions(+), 119 deletions(-) create mode 100644 flang/test/Lower/common-block-2.f90 create mode 100644 flang/test/Semantics/common-blocks-warn.f90 create mode 100644 flang/test/Semantics/common-blocks.f90 diff --git a/flang/docs/Extensions.md b/flang/docs/Extensions.md index e25331c85a21..568a222bde72 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 6b439f4e6d14..887c3bf9a184 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> + &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 1d4788451a42..0c9aba6d2e2f 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; - Program() = default; + Program(semantics::CommonBlockList &&commonBlocks) + : commonBlocks{std::move(commonBlocks)} {} Program(Program &&) = default; Program(const Program &) = delete; const std::list &getUnits() const { return units; } std::list &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; + 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 b64420eb20e4..bb96099dee4d 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>; using ConstructNode = std::variant tempNames_; const Scope *builtinsScope_{nullptr}; // module __Fortran_builtins std::list modFileParseTrees_; + std::unique_ptr commonBlockMap_; }; class Semantics { diff --git a/flang/lib/Lower/Bridge.cpp b/flang/lib/Lower/Bridge.cpp index dc4ee10767fe..662bb69d517f 100644 --- a/flang/lib/Lower/Bridge.cpp +++ b/flang/lib/Lower/Bridge.cpp @@ -178,29 +178,35 @@ public: /// 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 @@ private: }); } + /// 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 87ed2286f763..6c0df49a56e5 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> +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( - common.size() > 0 ? common.size() : 1); + const auto sz = + static_cast(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(); auto initFunc = [&](fir::FirOpBuilder &builder) { + mlir::IndexType idxTy = builder.getIndexType(); mlir::Value cb = builder.create(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(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> + 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(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 478ca19f7211..3be7ebedb3da 100644 --- a/flang/lib/Lower/PFTBuilder.cpp +++ b/flang/lib/Lower/PFTBuilder.cpp @@ -76,8 +76,9 @@ struct UnwrapStmt> { class PFTBuilder { public: PFTBuilder(const semantics::SemanticsContext &semanticsContext) - : pgm{std::make_unique()}, semanticsContext{ - semanticsContext} { + : pgm{std::make_unique( + 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 5698ef4690dd..82b4eeff390a 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 95bbd10e2e7a..c409bb59ee06 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 different 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 different 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 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(); + + 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 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_->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 000000000000..937b92e3d933 --- /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 different 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> { +! CHECK: %[[undef:.*]] = fir.undefined tuple> +! CHECK: %[[init:.*]] = fir.insert_value %[[undef]], %c42{{.*}}, [0 : index] : (tuple>, i32) -> tuple> +! CHECK: fir.has_value %[[init]] : tuple> + +! CHECK-LABEL: fir.global @_QBa : tuple> { +! CHECK: %[[undef:.*]] = fir.undefined tuple> +! CHECK: %[[init:.*]] = fir.insert_value %[[undef]], %c42{{.*}}, [0 : index] : (tuple>, i32) -> tuple> +! CHECK: fir.has_value %[[init]] : tuple> + + +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 9a103eacc88a..eed3125b71be 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 f2e9badec7e9..5acf64586121 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 { + ! CHECK: %[[init:.*]] = fir.insert_value %{{.*}}, %c42{{.*}}, [0 : index] : (tuple, i32) -> tuple + ! CHECK: fir.has_value %[[init]] : tuple + ! Module m1 defines simple data module m1 real :: x @@ -29,27 +50,6 @@ end module ! 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 { - ! CHECK: %[[init:.*]] = fir.insert_value %{{.*}}, %c42{{.*}}, [0 : index] : (tuple, i32) -> tuple - ! CHECK: fir.has_value %[[init]] : tuple - ! 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 06064fb755a5..6188a0064ce4 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 @@ end function ! 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 c48ba5fa2c07..c49c298d6b7c 100644 --- a/flang/test/Lower/pointer-initial-target-2.f90 +++ b/flang/test/Lower/pointer-initial-target-2.f90 @@ -5,6 +5,52 @@ ! More complete tests regarding the initial data target expression ! are done in pointer-initial-target.f90. +! Test pointer initial data target with pointer in common blocks +block data + real, pointer :: p + real, save, target :: b + common /a/ p + data p /b/ +! CHECK-LABEL: fir.global @_QBa : tuple>> + ! CHECK: %[[undef:.*]] = fir.undefined tuple>> + ! CHECK: %[[b:.*]] = fir.address_of(@_QEb) : !fir.ref + ! CHECK: %[[box:.*]] = fir.embox %[[b]] : (!fir.ref) -> !fir.box> + ! CHECK: %[[a:.*]] = fir.insert_value %[[undef]], %[[box]], [0 : index] : (tuple>>, !fir.box>) -> tuple>> + ! CHECK: fir.has_value %[[a]] : tuple>> +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, !fir.box>> + ! CHECK: fir.address_of(@_QBc2) : !fir.ref, !fir.box>>> +! CHECK-LABEL: fir.global @_QBc2 : tuple, !fir.box>> + ! CHECK: fir.address_of(@_QBc1) : !fir.ref, !fir.box>>> +end block data + +! Test pointer in a common with initial target in the same common. +block data snake + integer, target :: b = 42 + integer, pointer :: p => b + common /snake/ p, b +! CHECK-LABEL: fir.global @_QBsnake : tuple>, i32> + ! CHECK: %[[tuple0:.*]] = fir.undefined tuple>, i32> + ! CHECK: %[[snakeAddr:.*]] = fir.address_of(@_QBsnake) : !fir.ref>, i32>> + ! CHECK: %[[byteView:.*]] = fir.convert %[[snakeAddr:.*]] : (!fir.ref>, i32>>) -> !fir.ref> + ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[byteView]], %c24{{.*}} : (!fir.ref>, index) -> !fir.ref + ! CHECK: %[[bAddr:.*]] = fir.convert %[[coor]] : (!fir.ref) -> !fir.ref + ! CHECK: %[[box:.*]] = fir.embox %[[bAddr]] : (!fir.ref) -> !fir.box> + ! CHECK: %[[tuple1:.*]] = fir.insert_value %[[tuple0]], %[[box]], [0 : index] : (tuple>, i32>, !fir.box>) -> tuple>, i32> + ! CHECK: %[[tuple2:.*]] = fir.insert_value %[[tuple1]], %c42{{.*}}, [1 : index] : (tuple>, i32>, i32) -> tuple>, i32> + ! CHECK: fir.has_value %[[tuple2]] : tuple>, i32> +end block data + ! Test pointer initial data target in modules module some_mod real, target :: x(100) @@ -31,49 +77,3 @@ module some_mod_2 ! CHECK: %[[box:.*]] = fir.embox %[[y]](%[[shape]]) : (!fir.ref>, !fir.shapeshift<1>) -> !fir.box>> ! CHECK: fir.has_value %[[box]] : !fir.box>> end module - -! Test pointer initial data target with pointer in common blocks -block data - real, pointer :: p - real, save, target :: b - common /a/ p - data p /b/ -! CHECK-LABEL: fir.global @_QBa : tuple>> - ! CHECK: %[[undef:.*]] = fir.undefined tuple>> - ! CHECK: %[[b:.*]] = fir.address_of(@_QEb) : !fir.ref - ! CHECK: %[[box:.*]] = fir.embox %[[b]] : (!fir.ref) -> !fir.box> - ! CHECK: %[[a:.*]] = fir.insert_value %[[undef]], %[[box]], [0 : index] : (tuple>>, !fir.box>) -> tuple>> - ! CHECK: fir.has_value %[[a]] : tuple>> -end block data - -! Test pointer in a common with initial target in the same common. -block data snake - integer, target :: b = 42 - integer, pointer :: p => b - common /snake/ p, b -! CHECK-LABEL: fir.global @_QBsnake : tuple>, i32> - ! CHECK: %[[tuple0:.*]] = fir.undefined tuple>, i32> - ! CHECK: %[[snakeAddr:.*]] = fir.address_of(@_QBsnake) : !fir.ref>, i32>> - ! CHECK: %[[byteView:.*]] = fir.convert %[[snakeAddr:.*]] : (!fir.ref>, i32>>) -> !fir.ref> - ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[byteView]], %c24{{.*}} : (!fir.ref>, index) -> !fir.ref - ! CHECK: %[[bAddr:.*]] = fir.convert %[[coor]] : (!fir.ref) -> !fir.ref - ! CHECK: %[[box:.*]] = fir.embox %[[bAddr]] : (!fir.ref) -> !fir.box> - ! CHECK: %[[tuple1:.*]] = fir.insert_value %[[tuple0]], %[[box]], [0 : index] : (tuple>, i32>, !fir.box>) -> tuple>, i32> - ! CHECK: %[[tuple2:.*]] = fir.insert_value %[[tuple1]], %c42{{.*}}, [1 : index] : (tuple>, i32>, i32) -> tuple>, i32> - ! CHECK: fir.has_value %[[tuple2]] : tuple>, 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, !fir.box>> - ! CHECK: fir.address_of(@_QBc2) : !fir.ref, !fir.box>>> -! CHECK-LABEL: fir.global @_QBc2 : tuple, !fir.box>> - ! CHECK: fir.address_of(@_QBc1) : !fir.ref, !fir.box>>> -end block data diff --git a/flang/test/Semantics/common-blocks-warn.f90 b/flang/test/Semantics/common-blocks-warn.f90 new file mode 100644 index 000000000000..e4e486b64fb0 --- /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 different storage size. + +subroutine size_1 + common x, y + common /c/ xc, yc +end subroutine + +subroutine size_2 + ! OK, blank common size may always differ. + 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 000000000000..fccd48d67ee3 --- /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 a807d80cd231..975bbed8cb4d 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