Index: flang/lib/Lower/Bridge.cpp =================================================================== --- flang/lib/Lower/Bridge.cpp +++ flang/lib/Lower/Bridge.cpp @@ -420,54 +420,22 @@ bool createHostAssociateVarClone( const Fortran::semantics::Symbol &sym) override final { - mlir::Location loc = genLocation(sym.name()); - mlir::Type symType = genType(sym); + if (const auto *commonDet = + sym.detailsIf()) { + for (const auto &mem : commonDet->objects()) { + const auto *memDet = + mem->detailsIf(); + assert(memDet != nullptr && "No host-association found"); + fir::ExtendedValue memExv = genHostAssociateValue(memDet, *mem); + if (!bindIfNewSymbol(*mem, memExv)) + return false; + } + return true; + } + const auto *details = sym.detailsIf(); assert(details && "No host-association found"); - const Fortran::semantics::Symbol &hsym = details->symbol(); - Fortran::lower::SymbolBox hsb = lookupSymbol(hsym); - - auto allocate = [&](llvm::ArrayRef shape, - llvm::ArrayRef typeParams) -> mlir::Value { - mlir::Value allocVal = builder->allocateLocal( - loc, symType, mangleName(sym), toStringRef(sym.GetUltimate().name()), - /*pinned=*/true, shape, typeParams, - sym.GetUltimate().attrs().test(Fortran::semantics::Attr::TARGET)); - return allocVal; - }; - - fir::ExtendedValue hexv = getExtendedValue(hsb); - fir::ExtendedValue exv = hexv.match( - [&](const fir::BoxValue &box) -> fir::ExtendedValue { - const Fortran::semantics::DeclTypeSpec *type = sym.GetType(); - if (type && type->IsPolymorphic()) - TODO(loc, "create polymorphic host associated copy"); - // Create a contiguous temp with the same shape and length as - // the original variable described by a fir.box. - llvm::SmallVector extents = - fir::factory::getExtents(loc, *builder, hexv); - if (box.isDerivedWithLenParameters()) - TODO(loc, "get length parameters from derived type BoxValue"); - if (box.isCharacter()) { - mlir::Value len = fir::factory::readCharLen(*builder, loc, box); - mlir::Value temp = allocate(extents, {len}); - return fir::CharArrayBoxValue{temp, len, extents}; - } - return fir::ArrayBoxValue{allocate(extents, {}), extents}; - }, - [&](const fir::MutableBoxValue &box) -> fir::ExtendedValue { - // Allocate storage for a pointer/allocatble descriptor. - // No shape/lengths to be passed to the alloca. - return fir::MutableBoxValue(allocate({}, {}), - box.nonDeferredLenParams(), {}); - }, - [&](const auto &) -> fir::ExtendedValue { - mlir::Value temp = - allocate(fir::factory::getExtents(loc, *builder, hexv), - fir::getTypeParams(hexv)); - return fir::substBase(hexv, temp); - }); - + fir::ExtendedValue exv = genHostAssociateValue(details, sym); return bindIfNewSymbol(sym, exv); } @@ -635,6 +603,56 @@ [&sb](auto &) { return sb.toExtendedValue(); }); } + fir::ExtendedValue + genHostAssociateValue(const Fortran::semantics::HostAssocDetails *details, + const Fortran::semantics::Symbol &sym) { + mlir::Location loc = genLocation(sym.name()); + mlir::Type symType = genType(sym); + const Fortran::semantics::Symbol &hsym = details->symbol(); + Fortran::lower::SymbolBox hsb = lookupSymbol(hsym); + + auto allocate = [&](llvm::ArrayRef shape, + llvm::ArrayRef typeParams) -> mlir::Value { + mlir::Value allocVal = builder->allocateLocal( + loc, symType, mangleName(sym), toStringRef(sym.GetUltimate().name()), + /*pinned=*/true, shape, typeParams, + sym.GetUltimate().attrs().test(Fortran::semantics::Attr::TARGET)); + return allocVal; + }; + + fir::ExtendedValue hexv = getExtendedValue(hsb); + return hexv.match( + [&](const fir::BoxValue &box) -> fir::ExtendedValue { + const Fortran::semantics::DeclTypeSpec *type = sym.GetType(); + if (type && type->IsPolymorphic()) + TODO(loc, "create polymorphic host associated copy"); + // Create a contiguous temp with the same shape and length as + // the original variable described by a fir.box. + llvm::SmallVector extents = + fir::factory::getExtents(loc, *builder, hexv); + if (box.isDerivedWithLenParameters()) + TODO(loc, "get length parameters from derived type BoxValue"); + if (box.isCharacter()) { + mlir::Value len = fir::factory::readCharLen(*builder, loc, box); + mlir::Value temp = allocate(extents, {len}); + return fir::CharArrayBoxValue{temp, len, extents}; + } + return fir::ArrayBoxValue{allocate(extents, {}), extents}; + }, + [&](const fir::MutableBoxValue &box) -> fir::ExtendedValue { + // Allocate storage for a pointer/allocatble descriptor. + // No shape/lengths to be passed to the alloca. + return fir::MutableBoxValue(allocate({}, {}), + box.nonDeferredLenParams(), {}); + }, + [&](const auto &) -> fir::ExtendedValue { + mlir::Value temp = + allocate(fir::factory::getExtents(loc, *builder, hexv), + fir::getTypeParams(hexv)); + return fir::substBase(hexv, temp); + }); + } + /// Generate the address of loop variable \p sym. mlir::Value genLoopVariableAddress(mlir::Location loc, const Fortran::semantics::Symbol &sym) { Index: flang/test/Lower/OpenMP/omp-parallel-wsloop.f90 =================================================================== --- flang/test/Lower/OpenMP/omp-parallel-wsloop.f90 +++ flang/test/Lower/OpenMP/omp-parallel-wsloop.f90 @@ -102,3 +102,77 @@ ! CHECK: omp.terminator !$OMP END PARALLEL DO end subroutine + +! CHECK-LABEL: func.func @_QPprivate_clause_commonblock() { +! CHECK: %[[VAL_0:.*]] = fir.address_of(@_QBblk) : !fir.ref> +! CHECK: %[[VAL_1:.*]] = fir.convert %[[VAL_0]] : (!fir.ref>) -> !fir.ref> +! CHECK: %[[VAL_2:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_3:.*]] = fir.coordinate_of %[[VAL_1]], %[[VAL_2]] : (!fir.ref>, index) -> !fir.ref +! CHECK: %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (!fir.ref) -> !fir.ref +! CHECK: %[[VAL_5:.*]] = fir.convert %[[VAL_0]] : (!fir.ref>) -> !fir.ref> +! CHECK: %[[VAL_6:.*]] = arith.constant 4 : index +! CHECK: %[[VAL_7:.*]] = fir.coordinate_of %[[VAL_5]], %[[VAL_6]] : (!fir.ref>, index) -> !fir.ref +! CHECK: %[[VAL_8:.*]] = fir.convert %[[VAL_7]] : (!fir.ref) -> !fir.ref> +! CHECK: %[[VAL_9:.*]] = fir.convert %[[VAL_0]] : (!fir.ref>) -> !fir.ref> +! CHECK: %[[VAL_10:.*]] = arith.constant 48 : index +! CHECK: %[[VAL_11:.*]] = fir.coordinate_of %[[VAL_9]], %[[VAL_10]] : (!fir.ref>, index) -> !fir.ref +! CHECK: %[[VAL_12:.*]] = fir.convert %[[VAL_11]] : (!fir.ref) -> !fir.ref>>> +! CHECK: %[[VAL_13:.*]] = fir.convert %[[VAL_0]] : (!fir.ref>) -> !fir.ref> +! CHECK: %[[VAL_14:.*]] = arith.constant 72 : index +! CHECK: %[[VAL_15:.*]] = fir.coordinate_of %[[VAL_13]], %[[VAL_14]] : (!fir.ref>, index) -> !fir.ref +! CHECK: %[[VAL_16:.*]] = fir.convert %[[VAL_15]] : (!fir.ref) -> !fir.ref> +! CHECK: %[[VAL_17:.*]] = arith.constant 5 : index +! CHECK: %[[VAL_18:.*]] = fir.convert %[[VAL_0]] : (!fir.ref>) -> !fir.ref> +! CHECK: %[[VAL_19:.*]] = arith.constant 77 : index +! CHECK: %[[VAL_20:.*]] = fir.coordinate_of %[[VAL_18]], %[[VAL_19]] : (!fir.ref>, index) -> !fir.ref +! CHECK: %[[VAL_21:.*]] = fir.convert %[[VAL_20]] : (!fir.ref) -> !fir.ref>> +! CHECK: %[[VAL_22:.*]] = arith.constant 5 : index +! CHECK: %[[VAL_23:.*]] = fir.load %[[VAL_12]] : !fir.ref>>> +! CHECK: %[[VAL_24:.*]] = fir.box_addr %[[VAL_23]] : (!fir.box>>) -> !fir.ptr> +! CHECK: %[[VAL_25:.*]] = fir.convert %[[VAL_16]] : (!fir.ref>) -> !fir.ref> +! CHECK: %[[VAL_26:.*]] = fir.emboxchar %[[VAL_25]], %[[VAL_17]] : (!fir.ref>, index) -> !fir.boxchar<1> +! CHECK: %[[VAL_27:.*]] = fir.convert %[[VAL_21]] : (!fir.ref>>) -> !fir.ref> +! CHECK: %[[VAL_28:.*]] = fir.emboxchar %[[VAL_27]], %[[VAL_22]] : (!fir.ref>, index) -> !fir.boxchar<1> +! CHECK: %[[VAL_29:.*]] = fir.convert %[[VAL_24]] : (!fir.ptr>) -> !fir.ref> +! CHECK: fir.call @_QPsub1(%[[VAL_4]], %[[VAL_8]], %[[VAL_29]], %[[VAL_26]], %[[VAL_28]]) : (!fir.ref, !fir.ref>, !fir.ref>, !fir.boxchar<1>, !fir.boxchar<1>) -> () +! CHECK: omp.parallel { +! CHECK: %[[VAL_30:.*]] = fir.alloca i32 {bindc_name = "a", pinned, uniq_name = "_QFprivate_clause_commonblockEa"} +! CHECK: %[[VAL_31:.*]] = fir.alloca !fir.array<10xf32> {bindc_name = "b", pinned, uniq_name = "_QFprivate_clause_commonblockEb"} +! CHECK: %[[VAL_32:.*]] = fir.alloca !fir.complex<4> {bindc_name = "c", pinned, uniq_name = "_QFprivate_clause_commonblockEc"} +! CHECK: %[[VAL_33:.*]] = fir.alloca !fir.char<1,5> {bindc_name = "d", pinned, uniq_name = "_QFprivate_clause_commonblockEd"} +! CHECK: %[[VAL_34:.*]] = fir.alloca !fir.array<5x!fir.char<1,5>> {bindc_name = "e", pinned, uniq_name = "_QFprivate_clause_commonblockEe"} +! CHECK: %[[VAL_35:.*]] = fir.convert %[[VAL_33]] : (!fir.ref>) -> !fir.ref> +! CHECK: %[[VAL_36:.*]] = fir.emboxchar %[[VAL_35]], %[[VAL_17]] : (!fir.ref>, index) -> !fir.boxchar<1> +! CHECK: %[[VAL_37:.*]] = fir.convert %[[VAL_34]] : (!fir.ref>>) -> !fir.ref> +! CHECK: %[[VAL_38:.*]] = fir.emboxchar %[[VAL_37]], %[[VAL_22]] : (!fir.ref>, index) -> !fir.boxchar<1> +! CHECK: fir.call @_QPsub2(%[[VAL_30]], %[[VAL_31]], %[[VAL_32]], %[[VAL_36]], %[[VAL_38]]) : (!fir.ref, !fir.ref>, !fir.ref>, !fir.boxchar<1>, !fir.boxchar<1>) -> () +! CHECK: omp.terminator +! CHECK: } +! CHECK: %[[VAL_39:.*]] = fir.load %[[VAL_12]] : !fir.ref>>> +! CHECK: %[[VAL_40:.*]] = fir.box_addr %[[VAL_39]] : (!fir.box>>) -> !fir.ptr> +! CHECK: %[[VAL_41:.*]] = fir.convert %[[VAL_16]] : (!fir.ref>) -> !fir.ref> +! CHECK: %[[VAL_42:.*]] = fir.emboxchar %[[VAL_41]], %[[VAL_17]] : (!fir.ref>, index) -> !fir.boxchar<1> +! CHECK: %[[VAL_43:.*]] = fir.convert %[[VAL_21]] : (!fir.ref>>) -> !fir.ref> +! CHECK: %[[VAL_44:.*]] = fir.emboxchar %[[VAL_43]], %[[VAL_22]] : (!fir.ref>, index) -> !fir.boxchar<1> +! CHECK: %[[VAL_45:.*]] = fir.convert %[[VAL_40]] : (!fir.ptr>) -> !fir.ref> +! CHECK: fir.call @_QPsub3(%[[VAL_4]], %[[VAL_8]], %[[VAL_45]], %[[VAL_42]], %[[VAL_44]]) : (!fir.ref, !fir.ref>, !fir.ref>, !fir.boxchar<1>, !fir.boxchar<1>) -> () +! CHECK: return +! CHECK: } + +subroutine private_clause_commonblock() + + integer :: a + real :: b(10) + complex, pointer :: c + character(5) :: d, e(5) + common /blk/ a, b, c, d, e + + call sub1(a, b, c, d, e) + +!$OMP PARALLEL PRIVATE(/blk/) + call sub2(a, b, c, d, e) +!$OMP END PARALLEL + + call sub3(a, b, c, d, e) + +end subroutine