diff --git a/flang/include/flang/Lower/AbstractConverter.h b/flang/include/flang/Lower/AbstractConverter.h --- a/flang/include/flang/Lower/AbstractConverter.h +++ b/flang/include/flang/Lower/AbstractConverter.h @@ -101,6 +101,9 @@ virtual bool createHostAssociateVarClone(const Fortran::semantics::Symbol &sym) = 0; + virtual void + createHostAssociateVarCloneDealloc(const Fortran::semantics::Symbol &sym) = 0; + virtual void copyHostAssociateVar( const Fortran::semantics::Symbol &sym, mlir::OpBuilder::InsertPoint *copyAssignIP = nullptr) = 0; diff --git a/flang/include/flang/Lower/OpenMP.h b/flang/include/flang/Lower/OpenMP.h --- a/flang/include/flang/Lower/OpenMP.h +++ b/flang/include/flang/Lower/OpenMP.h @@ -13,6 +13,7 @@ #ifndef FORTRAN_LOWER_OPENMP_H #define FORTRAN_LOWER_OPENMP_H +#include "flang/Lower/SymbolMap.h" #include namespace mlir { @@ -44,6 +45,8 @@ void genOpenMPConstruct(AbstractConverter &, pft::Evaluation &, const parser::OpenMPConstruct &); +void genOpenMPEpilogue(AbstractConverter &, Fortran::lower::SymMap &, + const parser::OpenMPConstruct &); void genOpenMPDeclarativeConstruct(AbstractConverter &, pft::Evaluation &, const parser::OpenMPDeclarativeConstruct &); int64_t getCollapseValue(const Fortran::parser::OmpClauseList &clauseList); diff --git a/flang/include/flang/Lower/SymbolMap.h b/flang/include/flang/Lower/SymbolMap.h --- a/flang/include/flang/Lower/SymbolMap.h +++ b/flang/include/flang/Lower/SymbolMap.h @@ -315,6 +315,16 @@ return std::nullopt; } + llvm::DenseMap::const_iterator + scope_begin() const { + return symbolMapStack.back().begin(); + } + + llvm::DenseMap::const_iterator + scope_end() const { + return symbolMapStack.back().end(); + } + private: /// Add `symbol` to the current map and bind a `box`. void makeSym(semantics::SymbolRef symRef, const SymbolBox &box, diff --git a/flang/include/flang/Semantics/tools.h b/flang/include/flang/Semantics/tools.h --- a/flang/include/flang/Semantics/tools.h +++ b/flang/include/flang/Semantics/tools.h @@ -144,7 +144,7 @@ return symbol.attrs().test(Attr::ALLOCATABLE); } inline bool IsAllocatableOrPointer(const Symbol &symbol) { - return IsPointer(symbol) || IsAllocatable(symbol); + return IsPointer(symbol.GetUltimate()) || IsAllocatable(symbol.GetUltimate()); } inline bool IsNamedConstant(const Symbol &symbol) { return symbol.attrs().test(Attr::PARAMETER); @@ -577,8 +577,8 @@ LabelEnforce(SemanticsContext &context, std::set &&labels, parser::CharBlock constructSourcePosition, const char *construct) : context_{context}, labels_{labels}, - constructSourcePosition_{constructSourcePosition}, construct_{ - construct} {} + constructSourcePosition_{constructSourcePosition}, + construct_{construct} {} template bool Pre(const T &) { return true; } template bool Pre(const parser::Statement &statement) { currentStatementSourcePosition_ = statement.source; diff --git a/flang/lib/Lower/Bridge.cpp b/flang/lib/Lower/Bridge.cpp --- a/flang/lib/Lower/Bridge.cpp +++ b/flang/lib/Lower/Bridge.cpp @@ -569,18 +569,21 @@ const auto *details = sym.detailsIf(); assert(details && "No host-association found"); const Fortran::semantics::Symbol &hsym = details->symbol(); + mlir::Type hSymType = genType(hsym); 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()), + loc, + Fortran::semantics::IsAllocatableOrPointer(hsym) ? hSymType : 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 hexv = symBoxToExtendedValue(hsb); fir::ExtendedValue exv = hexv.match( [&](const fir::BoxValue &box) -> fir::ExtendedValue { const Fortran::semantics::DeclTypeSpec *type = sym.GetType(); @@ -603,7 +606,8 @@ // Allocate storage for a pointer/allocatble descriptor. // No shape/lengths to be passed to the alloca. return fir::MutableBoxValue(allocate({}, {}), - box.nonDeferredLenParams(), {}); + box.nonDeferredLenParams(), + box.getMutableProperties()); }, [&](const auto &) -> fir::ExtendedValue { mlir::Value temp = @@ -629,9 +633,77 @@ } } } + + // Initialise cloned allocatable + hexv.match( + [&](const fir::MutableBoxValue &box) -> void { + // Allocate storage for a pointer/allocatble descriptor. + // No shape/lengths to be passed to the alloca. + const auto new_box = exv.getBoxOf(); + + // allocate if allocated + mlir::Value isAllocated = + fir::factory::genIsAllocatedOrAssociatedTest(*builder, loc, box); + auto if_builder = builder->genIfThenElse(loc, isAllocated); + if_builder.genThen([&]() { + std::string name = mangleName(sym) + ".alloc"; + if (auto seqTy = symType.dyn_cast()) { + fir::ExtendedValue read = fir::factory::genMutableBoxRead( + *builder, loc, box, /*mayBePolymorphic=*/false); + auto read_box = read.getBoxOf(); + fir::factory::genInlinedAllocation( + *builder, loc, *new_box, read_box->getLBounds(), + read_box->getExtents(), + /*lenParams=*/std::nullopt, name, + /*mustBeHeap=*/true); + } else { + fir::factory::genInlinedAllocation( + *builder, loc, *new_box, + new_box->getMutableProperties().lbounds, + new_box->getMutableProperties().extents, + /*lenParams=*/std::nullopt, name, + /*mustBeHeap=*/true); + } + }); + if_builder.genElse([&]() { + // nullify box + auto empty = fir::factory::createUnallocatedBox( + *builder, loc, new_box->getBoxTy(), + new_box->nonDeferredLenParams(), {}); + builder->create(loc, empty, new_box->getAddr()); + }); + if_builder.end(); + }, + [&](const auto &) -> void { + // Do nothing + }); + return bindIfNewSymbol(sym, exv); } + void createHostAssociateVarCloneDealloc( + const Fortran::semantics::Symbol &sym) override final { + mlir::Location loc = genLocation(sym.name()); + Fortran::lower::SymbolBox hsb = lookupSymbol(sym); + + fir::ExtendedValue hexv = symBoxToExtendedValue(hsb); + hexv.match( + [&](const fir::MutableBoxValue &new_box) -> void { + // deallocate allocated in createHostAssociateVarClone value + mlir::Value needs_dealloc = + fir::factory::genIsAllocatedOrAssociatedTest(*builder, loc, + new_box); + builder->genIfThen(loc, needs_dealloc) + .genThen([&]() { + Fortran::lower::genDeallocateBox(*this, new_box, loc); + }) + .end(); + }, + [&](const auto &) -> void { + // Do nothing + }); + } + void copyHostAssociateVar( const Fortran::semantics::Symbol &sym, mlir::OpBuilder::InsertPoint *copyAssignIP = nullptr) override final { @@ -641,14 +713,14 @@ const Fortran::semantics::Symbol &hsym = sym.GetUltimate(); Fortran::lower::SymbolBox hsb = lookupOneLevelUpSymbol(hsym); assert(hsb && "Host symbol box not found"); - fir::ExtendedValue hexv = getExtendedValue(hsb); + fir::ExtendedValue hexv = symBoxToExtendedValue(hsb); // 2) Fetch the copied one that will mask the original. Fortran::lower::SymbolBox sb = shallowLookupSymbol(sym); assert(sb && "Host-associated symbol box not found"); assert(hsb.getAddr() != sb.getAddr() && "Host and associated symbol boxes are the same"); - fir::ExtendedValue exv = getExtendedValue(sb); + fir::ExtendedValue exv = symBoxToExtendedValue(sb); // 3) Perform the assignment. mlir::OpBuilder::InsertPoint insPt = builder->saveInsertionPoint(); @@ -670,23 +742,67 @@ mlir::Location loc = genLocation(sym.name()); mlir::Type symType = genType(sym); - if (auto seqTy = symType.dyn_cast()) { + + if (const auto box = rhs.getBoxOf()) { + const auto new_box = lhs.getBoxOf(); + // allocate if allocated + mlir::Value isAllocated = + fir::factory::genIsAllocatedOrAssociatedTest(*builder, loc, *box); + auto if_builder = builder->genIfThenElse(loc, isAllocated); + if_builder.genThen([&]() { + std::string name = mangleName(sym) + ".alloc"; + if (auto seqTy = symType.dyn_cast()) { + fir::ExtendedValue read = fir::factory::genMutableBoxRead( + *builder, loc, *box, /*mayBePolymorphic=*/false); + auto read_box = read.getBoxOf(); + fir::factory::genInlinedAllocation(*builder, loc, *new_box, + read_box->getLBounds(), + read_box->getExtents(), + /*lenParams=*/std::nullopt, name, + /*mustBeHeap=*/true); + } else { + fir::factory::genInlinedAllocation( + *builder, loc, *new_box, new_box->getMutableProperties().lbounds, + new_box->getMutableProperties().extents, + /*lenParams=*/std::nullopt, name, + /*mustBeHeap=*/true); + } + }); + if_builder.genElse([&]() { + // nullify box + auto empty = fir::factory::createUnallocatedBox( + *builder, loc, new_box->getBoxTy(), new_box->nonDeferredLenParams(), + {}); + builder->create(loc, empty, new_box->getAddr()); + }); + if_builder.end(); + + // and deallocate then + mlir::Value needs_dealloc = + fir::factory::genIsAllocatedOrAssociatedTest(*builder, loc, *new_box); + builder->genIfThen(loc, needs_dealloc) + .genThen( + [&]() { Fortran::lower::genDeallocateBox(*this, *new_box, loc); }) + .end(); + + // set insertion point inbetween + builder->setInsertionPointAfter(if_builder.getIfOp()); + } else if (auto seqTy = symType.dyn_cast()) { Fortran::lower::StatementContext stmtCtx; Fortran::lower::createSomeArrayAssignment(*this, lhs, rhs, localSymbols, stmtCtx); stmtCtx.finalizeAndReset(); } else if (hexv.getBoxOf()) { fir::factory::CharacterExprHelper{*builder, loc}.createAssign(lhs, rhs); - } else if (hexv.getBoxOf()) { - TODO(loc, "firstprivatisation of allocatable variables"); } else { auto loadVal = builder->create(loc, fir::getBase(rhs)); builder->create(loc, loadVal, fir::getBase(lhs)); } if (copyAssignIP && copyAssignIP->isSet() && - sym.test(Fortran::semantics::Symbol::Flag::OmpLastPrivate)) + sym.test(Fortran::semantics::Symbol::Flag::OmpLastPrivate)) { builder->restoreInsertionPoint(insPt); + } } //===--------------------------------------------------------------------===// @@ -935,15 +1051,6 @@ return true; } - fir::ExtendedValue getExtendedValue(Fortran::lower::SymbolBox sb) { - fir::ExtendedValue exv = symBoxToExtendedValue(sb); - // Dereference pointers and allocatables. - if (const auto *box = exv.getBoxOf()) - return fir::factory::genMutableBoxRead(*builder, getCurrentLocation(), - *box); - return exv; - } - /// Generate the address of loop variable \p sym. /// If \p sym is not mapped yet, allocate local storage for it. mlir::Value genLoopVariableAddress(mlir::Location loc, @@ -2212,6 +2319,7 @@ if (ompLoop) genOpenMPReduction(*this, *loopOpClauseList); + genOpenMPEpilogue(*this, localSymbols, omp); localSymbols.popScope(); builder->restoreInsertionPoint(insertPt); } diff --git a/flang/lib/Lower/OpenMP.cpp b/flang/lib/Lower/OpenMP.cpp --- a/flang/lib/Lower/OpenMP.cpp +++ b/flang/lib/Lower/OpenMP.cpp @@ -129,6 +129,7 @@ bool success = converter.createHostAssociateVarClone(*sym); (void)success; assert(success && "Privatization failed due to existing binding"); + if (sym->test(Fortran::semantics::Symbol::Flag::OmpFirstPrivate)) { fir::FirOpBuilder &firOpBuilder = converter.getFirOpBuilder(); mlir::OpBuilder::InsertPoint firstPrivIP, insPt; @@ -2414,6 +2415,17 @@ ompConstruct.u); } +void Fortran::lower::genOpenMPEpilogue( + Fortran::lower::AbstractConverter &converter, + Fortran::lower::SymMap &localSymbols, + const Fortran::parser::OpenMPConstruct &ompConstruct) { + for (auto i = localSymbols.scope_begin(); i != localSymbols.scope_end(); + ++i) { + auto sym = i->first; + converter.createHostAssociateVarCloneDealloc(*sym); + } +} + void Fortran::lower::genThreadprivateOp( Fortran::lower::AbstractConverter &converter, const Fortran::lower::pft::Variable &var) { diff --git a/flang/test/Lower/OpenMP/parallel-private-clause.f90 b/flang/test/Lower/OpenMP/parallel-private-clause.f90 --- a/flang/test/Lower/OpenMP/parallel-private-clause.f90 +++ b/flang/test/Lower/OpenMP/parallel-private-clause.f90 @@ -106,20 +106,23 @@ !FIRDialect-DAG: {{.*}} = fir.alloca !fir.box>> {bindc_name = "x2", uniq_name = "{{.*}}Ex2"} !FIRDialect-DAG: {{.*}} = fir.alloca !fir.heap> {uniq_name = "{{.*}}Ex2.addr"} !FIRDialect-DAG: {{.*}} = fir.address_of(@{{.*}}Ex3) : !fir.ref>> -!FIRDialect-DAG: [[TMP9:%.*]] = fir.address_of(@{{.*}}Ex4) : !fir.ref>>> +!FIRDialect-DAG: [[TMP8:%.*]] = fir.address_of(@{{.*}}Ex4) : !fir.ref>>> !FIRDialect: omp.parallel { -!FIRDialect-DAG: [[TMP37:%.*]] = fir.alloca i32 {bindc_name = "x", pinned, uniq_name = "{{.*}}Ex"} -!FIRDialect-DAG: [[TMP40:%.*]] = fir.alloca !fir.array, {{.*}} {bindc_name = "x2", pinned, uniq_name = "{{.*}}Ex2"} -!FIRDialect-DAG: [[TMP41:%.*]] = fir.alloca i32 {bindc_name = "x3", pinned, uniq_name = "{{.*}}Ex3"} -!FIRDialect-DAG: [[TMP42:%.*]] = fir.load [[TMP9]] : !fir.ref>>> -!FIRDialect-DAG: [[TMP43:%.*]]:3 = fir.box_dims [[TMP42]], {{.*}} : (!fir.box>>, index) -> (index, index, index) -!FIRDialect-DAG: [[TMP44:%.*]] = fir.alloca !fir.array, [[TMP43]]#1 {bindc_name = "x4", pinned, uniq_name = "{{.*}}Ex4"} -!FIRDialect-DAG: [[TMP52:%.*]] = fir.embox [[TMP40]]({{.*}}) : (!fir.ref>, !fir.shapeshift<1>) -> !fir.box> -!FIRDialect-DAG: {{.*}} = fir.convert [[TMP52]] : (!fir.box>) -> !fir.box -!FIRDialect-DAG: [[TMP58:%.*]] = fir.shape_shift [[TMP43]]#0, [[TMP43]]#1 : (index, index) -> !fir.shapeshift<1> -!FIRDialect-DAG: [[TMP59:%.*]] = fir.embox [[TMP44]]([[TMP58]]) : (!fir.ref>, !fir.shapeshift<1>) -> !fir.box> -!FIRDialect-DAG: {{.*}} = fir.convert [[TMP59]] : (!fir.box>) -> !fir.box +!FIRDialect-DAG: [[TMP35:%.*]] = fir.alloca !fir.box> {bindc_name = "x", pinned, uniq_name = "{{.*}}Ex"} +!FIRDialect-DAG: [[TMP39:%.*]] = fir.alloca !fir.box>> {bindc_name = "x2", pinned, uniq_name = "{{.*}}Ex2"} +!FIRDialect-DAG: [[TMP45:%.*]] = fir.alloca !fir.box> {bindc_name = "x3", pinned, uniq_name = "{{.*}}Ex3"} + +!FIRDialect-DAG: [[TMP51:%.*]] = fir.load [[TMP8]] : !fir.ref>>> +!FIRDialect-DAG: [[TMP97:%.*]] = fir.load [[TMP8]] : !fir.ref>>> +!FIRDialect-DAG: [[TMP98:%.*]]:3 = fir.box_dims [[TMP97]], {{.*}} : (!fir.box>>, index) -> (index, index, index) +!FIRDialect-DAG: [[TMP50:%.*]] = fir.alloca !fir.box>> {bindc_name = "x4", pinned, uniq_name = "{{.*}}Ex4"} + +! FIRDialect-DAG: [[TMP101:%.*]] = fir.allocmem !fir.array, {{.*}} {fir.must_be_heap = true, uniq_name = "{{.*}}Ex4.alloc"} +! FIRDialect-DAG: [[TMP102:%.*]] = fir.shape_shift {{.*}}#0, {{.*}} : (index, index) -> !fir.shapeshift<1> +! FIRDialect-DAG: [[TMP103:%.*]] = fir.embox [[TMP101]]([[TMP102]]) : (!fir.heap>, !fir.shapeshift<1>) -> !fir.box>> +! FIRDialect-DAG: fir.store [[TMP103]] to [[TMP50]] : !fir.ref>>> + subroutine private_clause_allocatable() @@ -133,3 +136,45 @@ !$OMP END PARALLEL end subroutine + + +!FIRDialect: func @_QPprivate_clause_real_call_allocatable() { +!FIRDialect-DAG: {{.*}} = fir.alloca !fir.box> {bindc_name = "x5", uniq_name = "{{.*}}Ex5"} +!FIRDialect-DAG: {{.*}} = fir.zero_bits !fir.heap +!FIRDialect-DAG: {{.*}} = fir.embox %1 : (!fir.heap) -> !fir.box> +!FIRDialect-DAG: fir.store %2 to %0 : !fir.ref>> +!FIRDialect-DAG: omp.parallel { +!FIRDialect-DAG: [[TMP203:%.*]] = fir.alloca !fir.box> {bindc_name = "x5", pinned, uniq_name = "{{.*}}Ex5"} + +!FIRDialect-DAG: fir.if %7 { + +!FIRDialect-DAG: fir.store %13 to [[TMP203]] : !fir.ref>> +!FIRDialect-DAG: } else { + +!FIRDialect-DAG: fir.store %13 to [[TMP203]] : !fir.ref>> +!FIRDialect-DAG: } +!FIRDialect-DAG: fir.call @_QFprivate_clause_real_call_allocatablePhelper_private_clause_real_call_allocatable([[TMP203]]) fastmath : (!fir.ref>>) -> () +!FIRDialect-DAG: %8 = fir.load [[TMP203]] : !fir.ref>> + +!FIRDialect-DAG: fir.if %11 { +!FIRDialect-DAG: %12 = fir.load [[TMP203]] : !fir.ref>> + +!FIRDialect-DAG: fir.store %15 to [[TMP203]] : !fir.ref>> +!FIRDialect-DAG: } +!FIRDialect-DAG: omp.terminator +!FIRDialect-DAG: } +!FIRDialect-DAG: return +!FIRDialect-DAG: } + + +subroutine private_clause_real_call_allocatable + real, allocatable :: x5 + !$omp parallel private(x5) + call helper_private_clause_real_call_allocatable(x5) + !$omp end parallel + contains + subroutine helper_private_clause_real_call_allocatable(x6) + real, allocatable :: x6 + print *, allocated(x6) + end subroutine +end subroutine