Skip to content

Commit 5d25267

Browse files
clementvalvdonaldsonjeanPerier
committed
[flang] Lower common block
This patch lowers common block variable to FIR. This patch is part of the upstreaming effort from fir-dev branch. Reviewed By: PeteSteinfeld Differential Revision: https://reviews.llvm.org/D121610 Co-authored-by: V Donaldson <[email protected]> Co-authored-by: Jean Perier <[email protected]>
1 parent 1856409 commit 5d25267

File tree

2 files changed

+307
-6
lines changed

2 files changed

+307
-6
lines changed

‎flang/lib/Lower/ConvertVariable.cpp

Lines changed: 234 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -568,6 +568,232 @@ static void instantiateLocal(Fortran::lower::AbstractConverter &converter,
568568
mapSymbolAttributes(converter, var, symMap, stmtCtx);
569569
}
570570

571+
/// Cast an alias address (variable part of an equivalence) to fir.ptr so that
572+
/// the optimizer is conservative and avoids doing copy elision in assignment
573+
/// involving equivalenced variables.
574+
/// TODO: Represent the equivalence aliasing constraint in another way to avoid
575+
/// pessimizing array assignments involving equivalenced variables.
576+
static mlir::Value castAliasToPointer(fir::FirOpBuilder &builder,
577+
mlir::Location loc, mlir::Type aliasType,
578+
mlir::Value aliasAddr) {
579+
return builder.createConvert(loc, fir::PointerType::get(aliasType),
580+
aliasAddr);
581+
}
582+
583+
//===--------------------------------------------------------------===//
584+
// COMMON blocks instantiation
585+
//===--------------------------------------------------------------===//
586+
587+
/// Does any member of the common block has an initializer ?
588+
static bool
589+
commonBlockHasInit(const Fortran::semantics::MutableSymbolVector &cmnBlkMems) {
590+
for (const Fortran::semantics::MutableSymbolRef &mem : cmnBlkMems) {
591+
if (const auto *memDet =
592+
mem->detailsIf<Fortran::semantics::ObjectEntityDetails>())
593+
if (memDet->init())
594+
return true;
595+
}
596+
return false;
597+
}
598+
599+
/// Build a tuple type for a common block based on the common block
600+
/// members and the common block size.
601+
/// This type is only needed to build common block initializers where
602+
/// the initial value is the collection of the member initial values.
603+
static mlir::TupleType getTypeOfCommonWithInit(
604+
Fortran::lower::AbstractConverter &converter,
605+
const Fortran::semantics::MutableSymbolVector &cmnBlkMems,
606+
std::size_t commonSize) {
607+
fir::FirOpBuilder &builder = converter.getFirOpBuilder();
608+
llvm::SmallVector<mlir::Type> members;
609+
std::size_t counter = 0;
610+
for (const Fortran::semantics::MutableSymbolRef &mem : cmnBlkMems) {
611+
if (const auto *memDet =
612+
mem->detailsIf<Fortran::semantics::ObjectEntityDetails>()) {
613+
if (mem->offset() > counter) {
614+
fir::SequenceType::Shape len = {
615+
static_cast<fir::SequenceType::Extent>(mem->offset() - counter)};
616+
mlir::IntegerType byteTy = builder.getIntegerType(8);
617+
auto memTy = fir::SequenceType::get(len, byteTy);
618+
members.push_back(memTy);
619+
counter = mem->offset();
620+
}
621+
if (memDet->init()) {
622+
mlir::Type memTy = converter.genType(*mem);
623+
members.push_back(memTy);
624+
counter = mem->offset() + mem->size();
625+
}
626+
}
627+
}
628+
if (counter < commonSize) {
629+
fir::SequenceType::Shape len = {
630+
static_cast<fir::SequenceType::Extent>(commonSize - counter)};
631+
mlir::IntegerType byteTy = builder.getIntegerType(8);
632+
auto memTy = fir::SequenceType::get(len, byteTy);
633+
members.push_back(memTy);
634+
}
635+
return mlir::TupleType::get(builder.getContext(), members);
636+
}
637+
638+
/// Common block members may have aliases. They are not in the common block
639+
/// member list from the symbol. We need to know about these aliases if they
640+
/// have initializer to generate the common initializer.
641+
/// This function takes care of adding aliases with initializer to the member
642+
/// list.
643+
static Fortran::semantics::MutableSymbolVector
644+
getCommonMembersWithInitAliases(const Fortran::semantics::Symbol &common) {
645+
const auto &commonDetails =
646+
common.get<Fortran::semantics::CommonBlockDetails>();
647+
auto members = commonDetails.objects();
648+
649+
// The number and size of equivalence and common is expected to be small, so
650+
// no effort is given to optimize this loop of complexity equivalenced
651+
// common members * common members
652+
for (const Fortran::semantics::EquivalenceSet &set :
653+
common.owner().equivalenceSets())
654+
for (const Fortran::semantics::EquivalenceObject &obj : set) {
655+
if (!obj.symbol.test(Fortran::semantics::Symbol::Flag::CompilerCreated)) {
656+
if (const auto &details =
657+
obj.symbol
658+
.detailsIf<Fortran::semantics::ObjectEntityDetails>()) {
659+
const Fortran::semantics::Symbol *com =
660+
FindCommonBlockContaining(obj.symbol);
661+
if (!details->init() || com != &common)
662+
continue;
663+
// This is an alias with an init that belongs to the list
664+
if (std::find(members.begin(), members.end(), obj.symbol) ==
665+
members.end())
666+
members.emplace_back(obj.symbol);
667+
}
668+
}
669+
}
670+
return members;
671+
}
672+
673+
/// Define a global for a common block if it does not already exist in the
674+
/// mlir module.
675+
/// There is no "declare" version since there is not a
676+
/// scope that owns common blocks more that the others. All scopes using
677+
/// a common block attempts to define it with common linkage.
678+
static fir::GlobalOp
679+
defineCommonBlock(Fortran::lower::AbstractConverter &converter,
680+
const Fortran::semantics::Symbol &common) {
681+
fir::FirOpBuilder &builder = converter.getFirOpBuilder();
682+
std::string commonName = Fortran::lower::mangle::mangleName(common);
683+
fir::GlobalOp global = builder.getNamedGlobal(commonName);
684+
if (global)
685+
return global;
686+
Fortran::semantics::MutableSymbolVector cmnBlkMems =
687+
getCommonMembersWithInitAliases(common);
688+
mlir::Location loc = converter.genLocation(common.name());
689+
mlir::IndexType idxTy = builder.getIndexType();
690+
mlir::StringAttr linkage = builder.createCommonLinkage();
691+
if (!common.name().size() || !commonBlockHasInit(cmnBlkMems)) {
692+
// A blank (anonymous) COMMON block must always be initialized to zero.
693+
// A named COMMON block sans initializers is also initialized to zero.
694+
// mlir::Vector types must have a strictly positive size, so at least
695+
// temporarily, force a zero size COMMON block to have one byte.
696+
const auto sz = static_cast<fir::SequenceType::Extent>(
697+
common.size() > 0 ? common.size() : 1);
698+
fir::SequenceType::Shape shape = {sz};
699+
mlir::IntegerType i8Ty = builder.getIntegerType(8);
700+
auto commonTy = fir::SequenceType::get(shape, i8Ty);
701+
auto vecTy = mlir::VectorType::get(sz, i8Ty);
702+
mlir::Attribute zero = builder.getIntegerAttr(i8Ty, 0);
703+
auto init = mlir::DenseElementsAttr::get(vecTy, llvm::makeArrayRef(zero));
704+
return builder.createGlobal(loc, commonTy, commonName, linkage, init);
705+
}
706+
707+
// Named common with initializer, sort members by offset before generating
708+
// the type and initializer.
709+
std::sort(cmnBlkMems.begin(), cmnBlkMems.end(),
710+
[](auto &s1, auto &s2) { return s1->offset() < s2->offset(); });
711+
mlir::TupleType commonTy =
712+
getTypeOfCommonWithInit(converter, cmnBlkMems, common.size());
713+
auto initFunc = [&](fir::FirOpBuilder &builder) {
714+
mlir::Value cb = builder.create<fir::UndefOp>(loc, commonTy);
715+
unsigned tupIdx = 0;
716+
std::size_t offset = 0;
717+
LLVM_DEBUG(llvm::dbgs() << "block {\n");
718+
for (const Fortran::semantics::MutableSymbolRef &mem : cmnBlkMems) {
719+
if (const auto *memDet =
720+
mem->detailsIf<Fortran::semantics::ObjectEntityDetails>()) {
721+
if (mem->offset() > offset) {
722+
++tupIdx;
723+
offset = mem->offset();
724+
}
725+
if (memDet->init()) {
726+
LLVM_DEBUG(llvm::dbgs()
727+
<< "offset: " << mem->offset() << " is " << *mem << '\n');
728+
Fortran::lower::StatementContext stmtCtx;
729+
auto initExpr = memDet->init().value();
730+
fir::ExtendedValue initVal =
731+
Fortran::semantics::IsPointer(*mem)
732+
? Fortran::lower::genInitialDataTarget(
733+
converter, loc, converter.genType(*mem), initExpr)
734+
: genInitializerExprValue(converter, loc, initExpr, stmtCtx);
735+
mlir::IntegerAttr offVal = builder.getIntegerAttr(idxTy, tupIdx);
736+
mlir::Value castVal = builder.createConvert(
737+
loc, commonTy.getType(tupIdx), fir::getBase(initVal));
738+
cb = builder.create<fir::InsertValueOp>(loc, commonTy, cb, castVal,
739+
builder.getArrayAttr(offVal));
740+
++tupIdx;
741+
offset = mem->offset() + mem->size();
742+
}
743+
}
744+
}
745+
LLVM_DEBUG(llvm::dbgs() << "}\n");
746+
builder.create<fir::HasValueOp>(loc, cb);
747+
};
748+
// create the global object
749+
return builder.createGlobal(loc, commonTy, commonName,
750+
/*isConstant=*/false, initFunc);
751+
}
752+
/// The COMMON block is a global structure. `var` will be at some offset
753+
/// within the COMMON block. Adds the address of `var` (COMMON + offset) to
754+
/// the symbol map.
755+
static void instantiateCommon(Fortran::lower::AbstractConverter &converter,
756+
const Fortran::semantics::Symbol &common,
757+
const Fortran::lower::pft::Variable &var,
758+
Fortran::lower::SymMap &symMap) {
759+
fir::FirOpBuilder &builder = converter.getFirOpBuilder();
760+
const Fortran::semantics::Symbol &varSym = var.getSymbol();
761+
mlir::Location loc = converter.genLocation(varSym.name());
762+
763+
mlir::Value commonAddr;
764+
if (Fortran::lower::SymbolBox symBox = symMap.lookupSymbol(common))
765+
commonAddr = symBox.getAddr();
766+
if (!commonAddr) {
767+
// introduce a local AddrOf and add it to the map
768+
fir::GlobalOp global = defineCommonBlock(converter, common);
769+
commonAddr = builder.create<fir::AddrOfOp>(loc, global.resultType(),
770+
global.getSymbol());
771+
772+
symMap.addSymbol(common, commonAddr);
773+
}
774+
std::size_t byteOffset = varSym.GetUltimate().offset();
775+
mlir::IntegerType i8Ty = builder.getIntegerType(8);
776+
mlir::Type i8Ptr = builder.getRefType(i8Ty);
777+
mlir::Type seqTy = builder.getRefType(builder.getVarLenSeqTy(i8Ty));
778+
mlir::Value base = builder.createConvert(loc, seqTy, commonAddr);
779+
mlir::Value offs =
780+
builder.createIntegerConstant(loc, builder.getIndexType(), byteOffset);
781+
auto varAddr = builder.create<fir::CoordinateOp>(loc, i8Ptr, base,
782+
mlir::ValueRange{offs});
783+
mlir::Type symType = converter.genType(var.getSymbol());
784+
mlir::Value local;
785+
if (Fortran::semantics::FindEquivalenceSet(var.getSymbol()) != nullptr)
786+
local = castAliasToPointer(builder, loc, symType, varAddr);
787+
else
788+
local = builder.createConvert(loc, builder.getRefType(symType), varAddr);
789+
Fortran::lower::StatementContext stmtCtx;
790+
mapSymbolAttributes(converter, var, symMap, stmtCtx, local);
791+
}
792+
793+
//===--------------------------------------------------------------===//
794+
// Lower Variables specification expressions and attributes
795+
//===--------------------------------------------------------------===//
796+
571797
/// Helper to decide if a dummy argument must be tracked in an BoxValue.
572798
static bool lowerToBoxValue(const Fortran::semantics::Symbol &sym,
573799
mlir::Value dummyArg) {
@@ -1197,9 +1423,10 @@ void Fortran::lower::defineModuleVariable(
11971423
TODO(loc, "defineModuleVariable aggregateStore");
11981424
}
11991425
const Fortran::semantics::Symbol &sym = var.getSymbol();
1200-
if (Fortran::semantics::FindCommonBlockContaining(var.getSymbol())) {
1201-
const mlir::Location loc = converter.genLocation(sym.name());
1202-
TODO(loc, "defineModuleVariable common block");
1426+
if (const Fortran::semantics::Symbol *common =
1427+
Fortran::semantics::FindCommonBlockContaining(var.getSymbol())) {
1428+
// Define common block containing the variable.
1429+
defineCommonBlock(converter, *common);
12031430
} else if (var.isAlias()) {
12041431
// Do nothing. Mapping will be done on user side.
12051432
} else {
@@ -1216,9 +1443,10 @@ void Fortran::lower::instantiateVariable(AbstractConverter &converter,
12161443
const mlir::Location loc = converter.genLocation(sym.name());
12171444
if (var.isAggregateStore()) {
12181445
TODO(loc, "instantiateVariable AggregateStore");
1219-
} else if (Fortran::semantics::FindCommonBlockContaining(
1220-
var.getSymbol().GetUltimate())) {
1221-
TODO(loc, "instantiateVariable Common");
1446+
} else if (const Fortran::semantics::Symbol *common =
1447+
Fortran::semantics::FindCommonBlockContaining(
1448+
var.getSymbol().GetUltimate())) {
1449+
instantiateCommon(converter, *common, var, symMap);
12221450
} else if (var.isAlias()) {
12231451
TODO(loc, "instantiateVariable Alias");
12241452
} else if (var.isGlobal()) {

‎flang/test/Lower/common-block.f90

Lines changed: 73 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,73 @@
1+
! RUN: bbc %s -o - | tco | FileCheck %s
2+
3+
! CHECK: @_QB = common global [8 x i8] zeroinitializer
4+
! CHECK: @_QBx = global { float, float } { float 1.0{{.*}}, float 2.0{{.*}} }
5+
! CHECK: @_QBy = common global [12 x i8] zeroinitializer
6+
! CHECK: @_QBz = global { i32, [4 x i8], float } { i32 42, [4 x i8] undef, float 3.000000e+00 }
7+
! CHECK: @_QBrien = common global [1 x i8] zeroinitializer
8+
! CHECK: @_QBwith_empty_equiv = common global [8 x i8] zeroinitializer
9+
10+
! CHECK-LABEL: _QPs0
11+
subroutine s0
12+
common // a0, b0
13+
14+
! CHECK: call void @_QPs(float* bitcast ([8 x i8]* @_QB to float*), float* bitcast (i8* getelementptr inbounds ([8 x i8], [8 x i8]* @_QB, i32 0, i64 4) to float*))
15+
call s(a0, b0)
16+
end subroutine s0
17+
18+
! CHECK-LABEL: _QPs1
19+
subroutine s1
20+
common /x/ a1, b1
21+
data a1 /1.0/, b1 /2.0/
22+
23+
! CHECK: call void @_QPs(float* getelementptr inbounds ({ float, float }, { float, float }* @_QBx, i32 0, i32 0), float* bitcast (i8* getelementptr (i8, i8* bitcast ({ float, float }* @_QBx to i8*), i64 4) to float*))
24+
call s(a1, b1)
25+
end subroutine s1
26+
27+
! CHECK-LABEL: _QPs2
28+
subroutine s2
29+
common /y/ a2, b2, c2
30+
31+
! CHECK: call void @_QPs(float* bitcast ([12 x i8]* @_QBy to float*), float* bitcast (i8* getelementptr inbounds ([12 x i8], [12 x i8]* @_QBy, i32 0, i64 4) to float*))
32+
call s(a2, b2)
33+
end subroutine s2
34+
35+
! Test that common initialized through aliases of common members are getting
36+
! the correct initializer.
37+
! CHECK-LABEL: _QPs3
38+
subroutine s3
39+
integer :: i = 42
40+
real :: x
41+
complex :: c
42+
real :: glue(2)
43+
real :: y = 3.
44+
equivalence (i, x), (glue(1), c), (glue(2), y)
45+
! x and c are not directly initialized, but overlapping aliases are.
46+
common /z/ x, c
47+
end subroutine s3
48+
49+
module mod_with_common
50+
integer :: i, j
51+
common /c_in_mod/ i, j
52+
end module
53+
! CHECK-LABEL: _QPs4
54+
subroutine s4
55+
use mod_with_common
56+
! CHECK: load i32, i32* bitcast ([8 x i8]* @_QBc_in_mod to i32*)
57+
print *, i
58+
! CHECK: load i32, i32* bitcast (i8* getelementptr inbounds ([8 x i8], [8 x i8]* @_QBc_in_mod, i32 0, i64 4) to i32*)
59+
print *, j
60+
end subroutine s4
61+
62+
! CHECK-LABEL: _QPs5
63+
subroutine s5
64+
real r(1:0)
65+
common /rien/ r
66+
end subroutine s5
67+
68+
! CHECK-LABEL: _QPs6
69+
subroutine s6
70+
real r1(1:0), r2(1:0), x, y
71+
common /with_empty_equiv/ x, r1, y
72+
equivalence(r1, r2)
73+
end subroutine s6

0 commit comments

Comments
 (0)