diff --git a/flang/include/flang/Lower/AbstractConverter.h b/flang/include/flang/Lower/AbstractConverter.h index daded9091780e..583fa6fb215a7 100644 --- a/flang/include/flang/Lower/AbstractConverter.h +++ b/flang/include/flang/Lower/AbstractConverter.h @@ -61,6 +61,7 @@ class SymMap; struct SymbolBox; namespace pft { struct Variable; +struct FunctionLikeUnit; } using SomeExpr = Fortran::evaluate::Expr; @@ -233,6 +234,10 @@ class AbstractConverter { virtual bool isRegisteredDummySymbol(Fortran::semantics::SymbolRef symRef) const = 0; + /// Returns the FunctionLikeUnit being lowered, if any. + virtual const Fortran::lower::pft::FunctionLikeUnit * + getCurrentFunctionUnit() const = 0; + //===--------------------------------------------------------------------===// // Types //===--------------------------------------------------------------------===// diff --git a/flang/include/flang/Lower/PFTBuilder.h b/flang/include/flang/Lower/PFTBuilder.h index 7f1b93c564b4c..9b9d9febc190a 100644 --- a/flang/include/flang/Lower/PFTBuilder.h +++ b/flang/include/flang/Lower/PFTBuilder.h @@ -693,6 +693,7 @@ struct FunctionLikeUnit : public ProgramUnit { /// Return the host associations for this function like unit. The list of host /// associations are kept in the host procedure. HostAssociations &getHostAssoc() { return hostAssociations; } + const HostAssociations &getHostAssoc() const { return hostAssociations; }; LLVM_DUMP_METHOD void dump() const; diff --git a/flang/include/flang/Optimizer/Dialect/FIRAttr.td b/flang/include/flang/Optimizer/Dialect/FIRAttr.td index 4e84959a3b3e1..e3474da6685af 100644 --- a/flang/include/flang/Optimizer/Dialect/FIRAttr.td +++ b/flang/include/flang/Optimizer/Dialect/FIRAttr.td @@ -32,14 +32,17 @@ def FIRpointer : I32BitEnumAttrCaseBit<"pointer", 9>; def FIRtarget : I32BitEnumAttrCaseBit<"target", 10>; def FIRvalue : I32BitEnumAttrCaseBit<"value", 11>; def FIRvolatile : I32BitEnumAttrCaseBit<"fortran_volatile", 12, "volatile">; +// Used inside internal procedure to flag variables host associated from parent procedure. def FIRHostAssoc : I32BitEnumAttrCaseBit<"host_assoc", 13>; +// Used inside parent procedure to flag variables host associated in internal procedure. +def FIRInternalAssoc : I32BitEnumAttrCaseBit<"internal_assoc", 14>; def fir_FortranVariableFlagsEnum : I32BitEnumAttr< "FortranVariableFlagsEnum", "Fortran variable attributes", [FIRnoAttributes, FIRallocatable, FIRasynchronous, FIRbind_c, FIRcontiguous, FIRintent_in, FIRintent_inout, FIRintent_out, FIRoptional, FIRparameter, - FIRpointer, FIRtarget, FIRvalue, FIRvolatile, FIRHostAssoc]> { + FIRpointer, FIRtarget, FIRvalue, FIRvolatile, FIRHostAssoc, FIRInternalAssoc]> { let separator = ", "; let cppNamespace = "::fir"; let printBitEnumPrimaryGroups = 1; diff --git a/flang/lib/Lower/Bridge.cpp b/flang/lib/Lower/Bridge.cpp index 7f41742bf5e8b..cbae6955e2a07 100644 --- a/flang/lib/Lower/Bridge.cpp +++ b/flang/lib/Lower/Bridge.cpp @@ -1058,6 +1058,11 @@ class FirConverter : public Fortran::lower::AbstractConverter { return registeredDummySymbols.contains(sym); } + const Fortran::lower::pft::FunctionLikeUnit * + getCurrentFunctionUnit() const override final { + return currentFunctionUnit; + } + void registerTypeInfo(mlir::Location loc, Fortran::lower::SymbolRef typeInfoSym, const Fortran::semantics::DerivedTypeSpec &typeSpec, @@ -5595,6 +5600,7 @@ class FirConverter : public Fortran::lower::AbstractConverter { /// Lower a procedure (nest). void lowerFunc(Fortran::lower::pft::FunctionLikeUnit &funit) { setCurrentPosition(funit.getStartingSourceLoc()); + setCurrentFunctionUnit(&funit); for (int entryIndex = 0, last = funit.entryPointList.size(); entryIndex < last; ++entryIndex) { funit.setActiveEntry(entryIndex); @@ -5604,6 +5610,7 @@ class FirConverter : public Fortran::lower::AbstractConverter { endNewFunction(funit); } funit.setActiveEntry(0); + setCurrentFunctionUnit(nullptr); for (Fortran::lower::pft::ContainedUnit &unit : funit.containedUnitList) if (auto *f = std::get_if(&unit)) lowerFunc(*f); // internal procedure @@ -5967,12 +5974,17 @@ class FirConverter : public Fortran::lower::AbstractConverter { /// Reset all registered dummy symbols. void resetRegisteredDummySymbols() { registeredDummySymbols.clear(); } + void setCurrentFunctionUnit(Fortran::lower::pft::FunctionLikeUnit *unit) { + currentFunctionUnit = unit; + } + //===--------------------------------------------------------------------===// Fortran::lower::LoweringBridge &bridge; Fortran::evaluate::FoldingContext foldingContext; fir::FirOpBuilder *builder = nullptr; Fortran::lower::pft::Evaluation *evalPtr = nullptr; + Fortran::lower::pft::FunctionLikeUnit *currentFunctionUnit = nullptr; Fortran::lower::SymMap localSymbols; Fortran::parser::CharBlock currentPosition; TypeInfoConverter typeInfoConverter; diff --git a/flang/lib/Lower/ConvertVariable.cpp b/flang/lib/Lower/ConvertVariable.cpp index cc51d5a9bb8da..deb855e1069f7 100644 --- a/flang/lib/Lower/ConvertVariable.cpp +++ b/flang/lib/Lower/ConvertVariable.cpp @@ -1670,6 +1670,25 @@ cuf::DataAttributeAttr Fortran::lower::translateSymbolCUFDataAttribute( return cuf::getDataAttribute(mlirContext, cudaAttr); } +static bool +isCapturedInInternalProcedure(Fortran::lower::AbstractConverter &converter, + const Fortran::semantics::Symbol &sym) { + const Fortran::lower::pft::FunctionLikeUnit *funit = + converter.getCurrentFunctionUnit(); + if (!funit || funit->getHostAssoc().empty()) + return false; + if (funit->getHostAssoc().isAssociated(sym)) + return true; + // Consider that any capture of a variable that is in an equivalence with the + // symbol implies that the storage of the symbol may also be accessed inside + // the internal procedure and flag it as captured. + if (const auto *equivSet = Fortran::semantics::FindEquivalenceSet(sym)) + for (const Fortran::semantics::EquivalenceObject &eqObj : *equivSet) + if (funit->getHostAssoc().isAssociated(eqObj.symbol)) + return true; + return false; +} + /// Map a symbol to its FIR address and evaluated specification expressions. /// Not for symbols lowered to fir.box. /// Will optionally create fir.declare. @@ -1705,8 +1724,12 @@ static void genDeclareSymbol(Fortran::lower::AbstractConverter &converter, if (len) lenParams.emplace_back(len); auto name = converter.mangleName(sym); + fir::FortranVariableFlagsEnum extraFlags = {}; + if (isCapturedInInternalProcedure(converter, sym)) + extraFlags = extraFlags | fir::FortranVariableFlagsEnum::internal_assoc; fir::FortranVariableFlagsAttr attributes = - Fortran::lower::translateSymbolAttributes(builder.getContext(), sym); + Fortran::lower::translateSymbolAttributes(builder.getContext(), sym, + extraFlags); cuf::DataAttributeAttr dataAttr = Fortran::lower::translateSymbolCUFDataAttribute(builder.getContext(), sym); @@ -1793,6 +1816,8 @@ void Fortran::lower::genDeclareSymbol( !sym.detailsIf()) { fir::FirOpBuilder &builder = converter.getFirOpBuilder(); const mlir::Location loc = genLocation(converter, sym); + if (isCapturedInInternalProcedure(converter, sym)) + extraFlags = extraFlags | fir::FortranVariableFlagsEnum::internal_assoc; // FIXME: Using the ultimate symbol for translating symbol attributes will // lead to situations where the VOLATILE/ASYNCHRONOUS attributes are not // propagated to the hlfir.declare (these attributes can be added when diff --git a/flang/test/Lower/HLFIR/assumed-rank-internal-proc.f90 b/flang/test/Lower/HLFIR/assumed-rank-internal-proc.f90 index 690ceb64a03cf..e46d21d915eb1 100644 --- a/flang/test/Lower/HLFIR/assumed-rank-internal-proc.f90 +++ b/flang/test/Lower/HLFIR/assumed-rank-internal-proc.f90 @@ -17,7 +17,7 @@ subroutine internal() ! CHECK-LABEL: func.func @_QPtest_assumed_rank( ! CHECK-SAME: %[[VAL_0:.*]]: !fir.box> {fir.bindc_name = "x"}) { ! CHECK: %[[VAL_1:.*]] = fir.dummy_scope : !fir.dscope -! CHECK: %[[VAL_2:.*]]:2 = hlfir.declare %[[VAL_0]] dummy_scope %[[VAL_1]] {uniq_name = "_QFtest_assumed_rankEx"} : (!fir.box>, !fir.dscope) -> (!fir.box>, !fir.box>) +! CHECK: %[[VAL_2:.*]]:2 = hlfir.declare %[[VAL_0]] dummy_scope %[[VAL_1]] {fortran_attrs = #fir.var_attrs, uniq_name = "_QFtest_assumed_rankEx"} : (!fir.box>, !fir.dscope) -> (!fir.box>, !fir.box>) ! CHECK: %[[VAL_3:.*]] = fir.alloca tuple>> ! CHECK: %[[VAL_4:.*]] = arith.constant 0 : i32 ! CHECK: %[[VAL_5:.*]] = fir.coordinate_of %[[VAL_3]], %[[VAL_4]] : (!fir.ref>>>, i32) -> !fir.ref>> @@ -55,7 +55,7 @@ subroutine internal() ! CHECK-LABEL: func.func @_QPtest_assumed_rank_optional( ! CHECK-SAME: %[[VAL_0:.*]]: !fir.class> {fir.bindc_name = "x", fir.optional}) { ! CHECK: %[[VAL_1:.*]] = fir.dummy_scope : !fir.dscope -! CHECK: %[[VAL_2:.*]]:2 = hlfir.declare %[[VAL_0]] dummy_scope %[[VAL_1]] {fortran_attrs = #fir.var_attrs, uniq_name = "_QFtest_assumed_rank_optionalEx"} : (!fir.class>, !fir.dscope) -> (!fir.class>, !fir.class>) +! CHECK: %[[VAL_2:.*]]:2 = hlfir.declare %[[VAL_0]] dummy_scope %[[VAL_1]] {fortran_attrs = #fir.var_attrs, uniq_name = "_QFtest_assumed_rank_optionalEx"} : (!fir.class>, !fir.dscope) -> (!fir.class>, !fir.class>) ! CHECK: %[[VAL_3:.*]] = fir.alloca tuple>> ! CHECK: %[[VAL_4:.*]] = arith.constant 0 : i32 ! CHECK: %[[VAL_5:.*]] = fir.coordinate_of %[[VAL_3]], %[[VAL_4]] : (!fir.ref>>>, i32) -> !fir.ref>> @@ -107,7 +107,7 @@ subroutine internal() ! CHECK-LABEL: func.func @_QPtest_assumed_rank_ptr( ! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref>>> {fir.bindc_name = "x"}) { ! CHECK: %[[VAL_1:.*]] = fir.dummy_scope : !fir.dscope -! CHECK: %[[VAL_2:.*]]:2 = hlfir.declare %[[VAL_0]] dummy_scope %[[VAL_1]] {fortran_attrs = #fir.var_attrs, uniq_name = "_QFtest_assumed_rank_ptrEx"} : (!fir.ref>>>, !fir.dscope) -> (!fir.ref>>>, !fir.ref>>>) +! CHECK: %[[VAL_2:.*]]:2 = hlfir.declare %[[VAL_0]] dummy_scope %[[VAL_1]] {fortran_attrs = #fir.var_attrs, uniq_name = "_QFtest_assumed_rank_ptrEx"} : (!fir.ref>>>, !fir.dscope) -> (!fir.ref>>>, !fir.ref>>>) ! CHECK: %[[VAL_3:.*]] = fir.alloca tuple>>>> ! CHECK: %[[VAL_4:.*]] = arith.constant 0 : i32 ! CHECK: %[[VAL_5:.*]] = fir.coordinate_of %[[VAL_3]], %[[VAL_4]] : (!fir.ref>>>>>, i32) -> !fir.llvm_ptr>>>> diff --git a/flang/test/Lower/HLFIR/cray-pointers.f90 b/flang/test/Lower/HLFIR/cray-pointers.f90 index ae903c8b44be7..bb49977dd2227 100644 --- a/flang/test/Lower/HLFIR/cray-pointers.f90 +++ b/flang/test/Lower/HLFIR/cray-pointers.f90 @@ -381,12 +381,12 @@ subroutine internal() ! CHECK: %[[VAL_1:.*]] = fir.alloca !fir.box>> ! CHECK: %[[VAL_2:.*]]:2 = hlfir.declare %[[VAL_0]] dummy_scope %{{[0-9]+}} {uniq_name = "_QFtest_craypointer_captureEn"} : (!fir.ref, !fir.dscope) -> (!fir.ref, !fir.ref) ! CHECK: %[[VAL_3:.*]] = fir.alloca i64 {bindc_name = "cray_pointer", uniq_name = "_QFtest_craypointer_captureEcray_pointer"} -! CHECK: %[[VAL_4:.*]]:2 = hlfir.declare %[[VAL_3]] {uniq_name = "_QFtest_craypointer_captureEcray_pointer"} : (!fir.ref) -> (!fir.ref, !fir.ref) +! CHECK: %[[VAL_4:.*]]:2 = hlfir.declare %[[VAL_3]] {fortran_attrs = #fir.var_attrs, uniq_name = "_QFtest_craypointer_captureEcray_pointer"} : (!fir.ref) -> (!fir.ref, !fir.ref) ! CHECK: %[[VAL_5:.*]] = fir.load %[[VAL_2]]#0 : !fir.ref ! CHECK: %[[VAL_6:.*]] = arith.constant 0 : i32 ! CHECK: %[[VAL_7:.*]] = arith.cmpi sgt, %[[VAL_5]], %[[VAL_6]] : i32 ! CHECK: %[[VAL_8:.*]] = arith.select %[[VAL_7]], %[[VAL_5]], %[[VAL_6]] : i32 -! CHECK: %[[VAL_9:.*]]:2 = hlfir.declare %[[VAL_1]] typeparams %[[VAL_8]] {fortran_attrs = #fir.var_attrs, uniq_name = "_QFtest_craypointer_captureEcray_pointee"} : (!fir.ref>>>, i32) -> (!fir.ref>>>, !fir.ref>>>) +! CHECK: %[[VAL_9:.*]]:2 = hlfir.declare %[[VAL_1]] typeparams %[[VAL_8]] {fortran_attrs = #fir.var_attrs, uniq_name = "_QFtest_craypointer_captureEcray_pointee"} : (!fir.ref>>>, i32) -> (!fir.ref>>>, !fir.ref>>>) ! CHECK: %[[VAL_10:.*]] = fir.zero_bits !fir.ptr> ! CHECK: %[[VAL_11:.*]] = fir.embox %[[VAL_10]] typeparams %[[VAL_8]] : (!fir.ptr>, i32) -> !fir.box>> ! CHECK: fir.store %[[VAL_11]] to %[[VAL_9]]#0 : !fir.ref>>> diff --git a/flang/test/Lower/HLFIR/internal-procedures.f90 b/flang/test/Lower/HLFIR/internal-procedures.f90 index f0df1a7f6e64f..12d862bf316c3 100644 --- a/flang/test/Lower/HLFIR/internal-procedures.f90 +++ b/flang/test/Lower/HLFIR/internal-procedures.f90 @@ -9,6 +9,9 @@ subroutine internal call takes_array(x) end subroutine end subroutine +! CHECK-LABEL: func.func @_QPtest_explicit_shape_array( +! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare {{.*}} {fortran_attrs = #fir.var_attrs, uniq_name = "_QFtest_explicit_shape_arrayEx"} + ! CHECK-LABEL: func.func private @_QFtest_explicit_shape_arrayPinternal( ! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref>>> {fir.host_assoc}) attributes {fir.host_symbol = {{.*}}, llvm.linkage = #llvm.linkage} { ! CHECK: %[[VAL_1:.*]] = arith.constant 0 : i32 @@ -27,6 +30,9 @@ subroutine internal call takes_array(x) end subroutine end subroutine +! CHECK-LABEL: func.func @_QPtest_assumed_shape( +! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare {{.*}} {fortran_attrs = #fir.var_attrs, uniq_name = "_QFtest_assumed_shapeEx"} + ! CHECK-LABEL: func.func private @_QFtest_assumed_shapePinternal( ! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref>>> {fir.host_assoc}) attributes {fir.host_symbol = {{.*}}, llvm.linkage = #llvm.linkage} { ! CHECK: %[[VAL_1:.*]] = arith.constant 0 : i32 @@ -64,7 +70,7 @@ subroutine internal() end subroutine ! CHECK-LABEL: func.func @_QPtest_proc_pointer( ! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref ()>>) { -! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] dummy_scope %{{[0-9]+}} {fortran_attrs = #fir.var_attrs, uniq_name = "_QFtest_proc_pointerEp"} : (!fir.ref ()>>, !fir.dscope) -> (!fir.ref ()>>, !fir.ref ()>>) +! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] dummy_scope %{{[0-9]+}} {fortran_attrs = #fir.var_attrs, uniq_name = "_QFtest_proc_pointerEp"} : (!fir.ref ()>>, !fir.dscope) -> (!fir.ref ()>>, !fir.ref ()>>) ! CHECK: %[[VAL_2:.*]] = fir.alloca tuple ()>>> ! CHECK: %[[VAL_3:.*]] = arith.constant 0 : i32 ! CHECK: %[[VAL_4:.*]] = fir.coordinate_of %[[VAL_2]], %[[VAL_3]] : (!fir.ref ()>>>>, i32) -> !fir.llvm_ptr ()>>> @@ -79,3 +85,19 @@ subroutine internal() ! CHECK: %[[VAL_2:.*]] = fir.coordinate_of %[[VAL_0]], %[[VAL_1]] : (!fir.ref ()>>>>, i32) -> !fir.llvm_ptr ()>>> ! CHECK: %[[VAL_3:.*]] = fir.load %[[VAL_2]] : !fir.llvm_ptr ()>>> ! CHECK: %[[VAL_4:.*]]:2 = hlfir.declare %[[VAL_3]] {fortran_attrs = #fir.var_attrs, uniq_name = "_QFtest_proc_pointerEp"} : (!fir.ref ()>>) -> (!fir.ref ()>>, !fir.ref ()>>) + + +! Verify that all equivalence members gets the internal_assoc flag set if one +! of them is captured in an internal procedure. +subroutine test_captured_equiv() + real :: x, y + equivalence(x,y) + call internal() +contains +subroutine internal() + y = 0. +end subroutine +end subroutine +! CHECK-LABEL: func.func @_QPtest_captured_equiv() { +! CHECK: hlfir.declare %{{.*}} {fortran_attrs = #fir.var_attrs, uniq_name = "_QFtest_captured_equivEx"} +! CHECK: hlfir.declare %{{.*}} {fortran_attrs = #fir.var_attrs, uniq_name = "_QFtest_captured_equivEy"} diff --git a/flang/test/Lower/OpenMP/threadprivate-host-association-2.f90 b/flang/test/Lower/OpenMP/threadprivate-host-association-2.f90 index a8d29baf74f22..546d4920042d7 100644 --- a/flang/test/Lower/OpenMP/threadprivate-host-association-2.f90 +++ b/flang/test/Lower/OpenMP/threadprivate-host-association-2.f90 @@ -5,10 +5,10 @@ !CHECK: func.func @_QQmain() attributes {fir.bindc_name = "main"} { !CHECK: %[[A:.*]] = fir.alloca i32 {bindc_name = "a", uniq_name = "_QFEa"} -!CHECK: %[[A_DECL:.*]]:2 = hlfir.declare %[[A]] {uniq_name = "_QFEa"} : (!fir.ref) -> (!fir.ref, !fir.ref) +!CHECK: %[[A_DECL:.*]]:2 = hlfir.declare %[[A]] {fortran_attrs = #fir.var_attrs, uniq_name = "_QFEa"} : (!fir.ref) -> (!fir.ref, !fir.ref) !CHECK: %[[A_ADDR:.*]] = fir.address_of(@_QFEa) : !fir.ref !CHECK: %[[TP_A:.*]] = omp.threadprivate %[[A_ADDR]] : !fir.ref -> !fir.ref -!CHECK: %[[TP_A_DECL:.*]]:2 = hlfir.declare %[[TP_A]] {uniq_name = "_QFEa"} : (!fir.ref) -> (!fir.ref, !fir.ref) +!CHECK: %[[TP_A_DECL:.*]]:2 = hlfir.declare %[[TP_A]] {fortran_attrs = #fir.var_attrs, uniq_name = "_QFEa"} : (!fir.ref) -> (!fir.ref, !fir.ref) !CHECK: fir.call @_QFPsub() fastmath : () -> () !CHECK: return !CHECK: } diff --git a/flang/test/Lower/OpenMP/threadprivate-host-association.f90 b/flang/test/Lower/OpenMP/threadprivate-host-association.f90 index 096e510c19c69..4fd958ba3b68c 100644 --- a/flang/test/Lower/OpenMP/threadprivate-host-association.f90 +++ b/flang/test/Lower/OpenMP/threadprivate-host-association.f90 @@ -5,9 +5,9 @@ !CHECK: func.func @_QQmain() attributes {fir.bindc_name = "main"} { !CHECK: %[[A:.*]] = fir.address_of(@_QFEa) : !fir.ref -!CHECK: %[[A_DECL:.*]]:2 = hlfir.declare %[[A]] {uniq_name = "_QFEa"} : (!fir.ref) -> (!fir.ref, !fir.ref) +!CHECK: %[[A_DECL:.*]]:2 = hlfir.declare %[[A]] {fortran_attrs = #fir.var_attrs, uniq_name = "_QFEa"} : (!fir.ref) -> (!fir.ref, !fir.ref) !CHECK: %[[TP_A:.*]] = omp.threadprivate %[[A_DECL]]#1 : !fir.ref -> !fir.ref -!CHECK: %[[TP_A_DECL:.*]]:2 = hlfir.declare %[[TP_A]] {uniq_name = "_QFEa"} : (!fir.ref) -> (!fir.ref, !fir.ref) +!CHECK: %[[TP_A_DECL:.*]]:2 = hlfir.declare %[[TP_A]] {fortran_attrs = #fir.var_attrs, uniq_name = "_QFEa"} : (!fir.ref) -> (!fir.ref, !fir.ref) !CHECK: fir.call @_QFPsub() fastmath : () -> () !CHECK: return !CHECK: }