[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

Author: jeanPerier

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.

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

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

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 different 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
+  // different 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 {

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()) {

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 {

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);
   }

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(