diff --git a/flang/include/flang/Optimizer/Builder/HLFIRTools.h b/flang/include/flang/Optimizer/Builder/HLFIRTools.h index 19fc2c22f0d49..ac80873dc374f 100644 --- a/flang/include/flang/Optimizer/Builder/HLFIRTools.h +++ b/flang/include/flang/Optimizer/Builder/HLFIRTools.h @@ -60,7 +60,7 @@ class Entity : public mlir::Value { bool isVariable() const { return !isValue(); } bool isMutableBox() const { return hlfir::isBoxAddressType(getType()); } bool isProcedurePointer() const { - return fir::isBoxProcAddressType(getType()); + return hlfir::isFortranProcedurePointerType(getType()); } bool isBoxAddressOrValue() const { return hlfir::isBoxAddressOrValueType(getType()); diff --git a/flang/include/flang/Optimizer/Builder/TemporaryStorage.h b/flang/include/flang/Optimizer/Builder/TemporaryStorage.h index b17a75354e7d1..cdb23a64c5c8a 100644 --- a/flang/include/flang/Optimizer/Builder/TemporaryStorage.h +++ b/flang/include/flang/Optimizer/Builder/TemporaryStorage.h @@ -180,7 +180,7 @@ class AnyValueStack { /// dynamic type, bounds, and type parameters as the Nth variable that was /// pushed. It is implemented using runtime. /// Note that this is not meant to save POINTER or ALLOCATABLE descriptor -/// addresses, use AnyDescriptorAddressStack instead. +/// addresses, use AnyAddressStack instead. class AnyVariableStack { public: AnyVariableStack(mlir::Location loc, fir::FirOpBuilder &builder, @@ -205,19 +205,21 @@ class AnyVariableStack { mlir::Value retValueBox; }; -/// Data structure to stack descriptor addresses. It stores the descriptor -/// addresses as int_ptr values under the hood. -class AnyDescriptorAddressStack : public AnyValueStack { +/// Data structure to stack simple addresses (C pointers). It can be used to +/// store data base addresses, descriptor addresses, procedure addresses, and +/// pointer procedure address. It stores the addresses as int_ptr values under +/// the hood. +class AnyAddressStack : public AnyValueStack { public: - AnyDescriptorAddressStack(mlir::Location loc, fir::FirOpBuilder &builder, - mlir::Type descriptorAddressType); + AnyAddressStack(mlir::Location loc, fir::FirOpBuilder &builder, + mlir::Type addressType); void pushValue(mlir::Location loc, fir::FirOpBuilder &builder, mlir::Value value); mlir::Value fetch(mlir::Location loc, fir::FirOpBuilder &builder); private: - mlir::Type descriptorAddressType; + mlir::Type addressType; }; class TemporaryStorage; @@ -281,8 +283,7 @@ class TemporaryStorage { private: std::variant + AnyVariableStack, AnyVectorSubscriptStack, AnyAddressStack> impl; }; } // namespace fir::factory diff --git a/flang/include/flang/Optimizer/HLFIR/HLFIRDialect.h b/flang/include/flang/Optimizer/HLFIR/HLFIRDialect.h index 15296aa7e8c75..5152dee14ad65 100644 --- a/flang/include/flang/Optimizer/HLFIR/HLFIRDialect.h +++ b/flang/include/flang/Optimizer/HLFIR/HLFIRDialect.h @@ -82,6 +82,17 @@ inline bool isPolymorphicType(mlir::Type type) { return fir::isPolymorphicType(type); } +/// Is this the FIR type of a Fortran procedure pointer? +inline bool isFortranProcedurePointerType(mlir::Type type) { + return fir::isBoxProcAddressType(type); +} + +inline bool isFortranPointerObjectType(mlir::Type type) { + auto boxTy = + llvm::dyn_cast_or_null(fir::dyn_cast_ptrEleTy(type)); + return boxTy && boxTy.isPointer(); +} + /// Is this an SSA value type for the value of a Fortran procedure /// designator ? inline bool isFortranProcedureValue(mlir::Type type) { diff --git a/flang/include/flang/Optimizer/HLFIR/HLFIROpBase.td b/flang/include/flang/Optimizer/HLFIR/HLFIROpBase.td index 1b1ac61d4550f..ee0b5aa9760b1 100644 --- a/flang/include/flang/Optimizer/HLFIR/HLFIROpBase.td +++ b/flang/include/flang/Optimizer/HLFIR/HLFIROpBase.td @@ -91,10 +91,9 @@ def IsFortranVariablePred def AnyFortranVariable : Type; -def AnyFortranValue : TypeConstraint, "any Fortran value type">; +def IsFortranValuePred : CPred<"::hlfir::isFortranValueType($_self)">; +def AnyFortranValue + : TypeConstraint; def AnyFortranEntity : TypeConstraint lhsType = assign.lhs.GetType(); // Polymorphic pointer assignment is delegated to the runtime, and @@ -4383,7 +4381,6 @@ class FirConverter : public Fortran::lower::AbstractConverter { Fortran::lower::StatementContext lhsContext; hlfir::Entity lhs = Fortran::lower::convertExprToHLFIR( loc, *this, assign.lhs, localSymbols, lhsContext); - auto lhsYieldOp = builder->create(loc, lhs); Fortran::lower::genCleanUpInRegionIfAny( loc, *builder, lhsYieldOp.getCleanup(), lhsContext); @@ -4391,6 +4388,23 @@ class FirConverter : public Fortran::lower::AbstractConverter { // Lower RHS in its own region. builder->createBlock(®ionAssignOp.getRhsRegion()); Fortran::lower::StatementContext rhsContext; + mlir::Value rhs = + genForallPointerAssignmentRhs(loc, lhs, assign, rhsContext); + auto rhsYieldOp = builder->create(loc, rhs); + Fortran::lower::genCleanUpInRegionIfAny( + loc, *builder, rhsYieldOp.getCleanup(), rhsContext); + + builder->setInsertionPointAfter(regionAssignOp); + } + + mlir::Value + genForallPointerAssignmentRhs(mlir::Location loc, mlir::Value lhs, + const Fortran::evaluate::Assignment &assign, + Fortran::lower::StatementContext &rhsContext) { + if (Fortran::evaluate::IsProcedureDesignator(assign.rhs)) + return fir::getBase(Fortran::lower::convertExprToAddress( + loc, *this, assign.rhs, localSymbols, rhsContext)); + // Data target. hlfir::Entity rhs = Fortran::lower::convertExprToHLFIR( loc, *this, assign.rhs, localSymbols, rhsContext); // Create pointer descriptor value from the RHS. @@ -4398,12 +4412,7 @@ class FirConverter : public Fortran::lower::AbstractConverter { rhs = hlfir::Entity{builder->create(loc, rhs)}; auto lhsBoxType = llvm::cast(fir::unwrapRefType(lhs.getType())); - mlir::Value newBox = hlfir::genVariableBox(loc, *builder, rhs, lhsBoxType); - auto rhsYieldOp = builder->create(loc, newBox); - Fortran::lower::genCleanUpInRegionIfAny( - loc, *builder, rhsYieldOp.getCleanup(), rhsContext); - - builder->setInsertionPointAfter(regionAssignOp); + return hlfir::genVariableBox(loc, *builder, rhs, lhsBoxType); } // Create the 2 x newRank array with the bounds to be passed to the runtime as diff --git a/flang/lib/Optimizer/Builder/TemporaryStorage.cpp b/flang/lib/Optimizer/Builder/TemporaryStorage.cpp index 48c2cb2181a0b..9d2e9837a3df8 100644 --- a/flang/lib/Optimizer/Builder/TemporaryStorage.cpp +++ b/flang/lib/Optimizer/Builder/TemporaryStorage.cpp @@ -357,25 +357,33 @@ void fir::factory::AnyVectorSubscriptStack::destroy( } //===----------------------------------------------------------------------===// -// fir::factory::AnyDescriptorAddressStack implementation. +// fir::factory::AnyAddressStack implementation. //===----------------------------------------------------------------------===// -fir::factory::AnyDescriptorAddressStack::AnyDescriptorAddressStack( - mlir::Location loc, fir::FirOpBuilder &builder, - mlir::Type descriptorAddressType) +fir::factory::AnyAddressStack::AnyAddressStack(mlir::Location loc, + fir::FirOpBuilder &builder, + mlir::Type addressType) : AnyValueStack(loc, builder, builder.getIntPtrType()), - descriptorAddressType{descriptorAddressType} {} - -void fir::factory::AnyDescriptorAddressStack::pushValue( - mlir::Location loc, fir::FirOpBuilder &builder, mlir::Value variable) { - mlir::Value cast = - builder.createConvert(loc, builder.getIntPtrType(), variable); + addressType{addressType} {} + +void fir::factory::AnyAddressStack::pushValue(mlir::Location loc, + fir::FirOpBuilder &builder, + mlir::Value variable) { + mlir::Value cast = variable; + if (auto boxProcType = llvm::dyn_cast(variable.getType())) { + cast = + builder.create(loc, boxProcType.getEleTy(), variable); + } + cast = builder.createConvert(loc, builder.getIntPtrType(), cast); static_cast(this)->pushValue(loc, builder, cast); } -mlir::Value -fir::factory::AnyDescriptorAddressStack::fetch(mlir::Location loc, - fir::FirOpBuilder &builder) { +mlir::Value fir::factory::AnyAddressStack::fetch(mlir::Location loc, + fir::FirOpBuilder &builder) { mlir::Value addr = static_cast(this)->fetch(loc, builder); - return builder.createConvert(loc, descriptorAddressType, addr); + if (auto boxProcType = llvm::dyn_cast(addressType)) { + mlir::Value cast = builder.createConvert(loc, boxProcType.getEleTy(), addr); + return builder.create(loc, boxProcType, cast); + } + return builder.createConvert(loc, addressType, addr); } diff --git a/flang/lib/Optimizer/HLFIR/IR/HLFIROps.cpp b/flang/lib/Optimizer/HLFIR/IR/HLFIROps.cpp index 383e6a2630537..8851a3a7187b9 100644 --- a/flang/lib/Optimizer/HLFIR/IR/HLFIROps.cpp +++ b/flang/lib/Optimizer/HLFIR/IR/HLFIROps.cpp @@ -1891,18 +1891,33 @@ llvm::LogicalResult hlfir::RegionAssignOp::verify() { return mlir::success(); } -bool hlfir::RegionAssignOp::isPointerAssignment() { +static mlir::Type +getNonVectorSubscriptedLhsType(hlfir::RegionAssignOp regionAssign) { + hlfir::YieldOp yieldOp = mlir::dyn_cast_or_null( + getTerminator(regionAssign.getLhsRegion())); + return yieldOp ? yieldOp.getEntity().getType() : mlir::Type{}; +} + +bool hlfir::RegionAssignOp::isPointerObjectAssignment() { if (!getUserDefinedAssignment().empty()) return false; - hlfir::YieldOp yieldOp = - mlir::dyn_cast_or_null(getTerminator(getLhsRegion())); - if (!yieldOp) + mlir::Type lhsType = getNonVectorSubscriptedLhsType(*this); + return lhsType && hlfir::isFortranPointerObjectType(lhsType); +} + +bool hlfir::RegionAssignOp::isProcedurePointerAssignment() { + if (!getUserDefinedAssignment().empty()) return false; - mlir::Type lhsType = yieldOp.getEntity().getType(); - if (!hlfir::isBoxAddressType(lhsType)) + mlir::Type lhsType = getNonVectorSubscriptedLhsType(*this); + return lhsType && hlfir::isFortranProcedurePointerType(lhsType); +} + +bool hlfir::RegionAssignOp::isPointerAssignment() { + if (!getUserDefinedAssignment().empty()) return false; - auto baseBoxType = llvm::cast(fir::unwrapRefType(lhsType)); - return baseBoxType.isPointer(); + mlir::Type lhsType = getNonVectorSubscriptedLhsType(*this); + return lhsType && (hlfir::isFortranPointerObjectType(lhsType) || + hlfir::isFortranProcedurePointerType(lhsType)); } //===----------------------------------------------------------------------===// diff --git a/flang/lib/Optimizer/HLFIR/Transforms/LowerHLFIROrderedAssignments.cpp b/flang/lib/Optimizer/HLFIR/Transforms/LowerHLFIROrderedAssignments.cpp index 7561daefa3b83..5cae7cf443c86 100644 --- a/flang/lib/Optimizer/HLFIR/Transforms/LowerHLFIROrderedAssignments.cpp +++ b/flang/lib/Optimizer/HLFIR/Transforms/LowerHLFIROrderedAssignments.cpp @@ -1277,11 +1277,13 @@ void OrderedAssignmentRewriter::saveNonVectorSubscriptedAddress( [&] { temp = insertSavedEntity(region, fir::factory::SSARegister{}); }); else doBeforeLoopNest([&] { - if (var.isMutableBox()) - temp = - insertSavedEntity(region, fir::factory::AnyDescriptorAddressStack{ - loc, builder, var.getType()}); + if (var.isMutableBox() || var.isProcedure() || var.isProcedurePointer()) + // Store single C pointer to entity. + temp = insertSavedEntity( + region, fir::factory::AnyAddressStack{loc, builder, var.getType()}); else + // Store the base address and dynamic shape/length/type information + // as descriptor. temp = insertSavedEntity(region, fir::factory::AnyVariableStack{ loc, builder, var.getType()}); }); diff --git a/flang/test/HLFIR/order_assignments/forall-proc-pointer-assignment-codegen.fir b/flang/test/HLFIR/order_assignments/forall-proc-pointer-assignment-codegen.fir new file mode 100644 index 0000000000000..c5fcc4d943927 --- /dev/null +++ b/flang/test/HLFIR/order_assignments/forall-proc-pointer-assignment-codegen.fir @@ -0,0 +1,222 @@ +// Test code generation of hlfir.region_assign representing procedure pointer +// assignments inside FORALL. + +// RUN: fir-opt %s --lower-hlfir-ordered-assignments | FileCheck %s + +!t=!fir.type i32>}> +func.func @test_no_conflict(%arg0: !fir.ref> {fir.bindc_name = "x"}) { + %c10_i64 = arith.constant 10 : i64 + %c1_i64 = arith.constant 1 : i64 + %c10 = arith.constant 10 : index + %0 = fir.dummy_scope : !fir.dscope + %1 = fir.shape %c10 : (index) -> !fir.shape<1> + %2:2 = hlfir.declare %arg0(%1) dummy_scope %0 {uniq_name = "x"} : (!fir.ref>, !fir.shape<1>, !fir.dscope) -> (!fir.ref>, !fir.ref>) + hlfir.forall lb { + hlfir.yield %c1_i64 : i64 + } ub { + hlfir.yield %c10_i64 : i64 + } (%arg1: i64) { + hlfir.region_assign { + %3 = fir.address_of(@f1) : () -> i32 + %4 = fir.emboxproc %3 : (() -> i32) -> !fir.boxproc<() -> ()> + hlfir.yield %4 : !fir.boxproc<() -> ()> + } to { + %3 = hlfir.designate %2#0 (%arg1) : (!fir.ref>, i64) -> !fir.ref + %4 = hlfir.designate %3{"p"} {fortran_attrs = #fir.var_attrs} : (!fir.ref) -> !fir.ref i32>> + hlfir.yield %4 : !fir.ref i32>> + } + } + return +} +// CHECK-LABEL: func.func @test_no_conflict( +// CHECK: %[[VAL_1:.*]] = arith.constant 10 : i64 +// CHECK: %[[VAL_2:.*]] = arith.constant 1 : i64 +// CHECK: %[[VAL_3:.*]] = arith.constant 10 : index +// CHECK: %[[VAL_4:.*]] = fir.dummy_scope : !fir.dscope +// CHECK: %[[VAL_5:.*]] = fir.shape %[[VAL_3]] : (index) -> !fir.shape<1> +// CHECK: %[[VAL_6:.*]]:2 = hlfir.declare{{.*}}"x" +// CHECK: %[[VAL_7:.*]] = fir.convert %[[VAL_2]] : (i64) -> index +// CHECK: %[[VAL_8:.*]] = fir.convert %[[VAL_1]] : (i64) -> index +// CHECK: %[[VAL_9:.*]] = arith.constant 1 : index +// CHECK: fir.do_loop %[[VAL_10:.*]] = %[[VAL_7]] to %[[VAL_8]] step %[[VAL_9]] { +// CHECK: %[[VAL_11:.*]] = fir.convert %[[VAL_10]] : (index) -> i64 +// CHECK: %[[VAL_12:.*]] = hlfir.designate %[[VAL_6]]#0 (%[[VAL_11]]) : (!fir.ref i32>}>>>, i64) -> !fir.ref i32>}>> +// CHECK: %[[VAL_13:.*]] = hlfir.designate %[[VAL_12]]{"p"} {fortran_attrs = #fir.var_attrs} : (!fir.ref i32>}>>) -> !fir.ref i32>> +// CHECK: %[[VAL_14:.*]] = fir.address_of(@f1) : () -> i32 +// CHECK: %[[VAL_15:.*]] = fir.emboxproc %[[VAL_14]] : (() -> i32) -> !fir.boxproc<() -> ()> +// CHECK: %[[VAL_16:.*]] = fir.convert %[[VAL_15]] : (!fir.boxproc<() -> ()>) -> !fir.boxproc<() -> i32> +// CHECK: fir.store %[[VAL_16]] to %[[VAL_13]] : !fir.ref i32>> +// CHECK: } +// CHECK: return +// CHECK: } + +func.func @test_need_to_save_rhs(%arg0: !fir.ref> {fir.bindc_name = "x"}) { + %c10_i64 = arith.constant 10 : i64 + %c1_i64 = arith.constant 1 : i64 + %c10 = arith.constant 10 : index + %0 = fir.dummy_scope : !fir.dscope + %1 = fir.shape %c10 : (index) -> !fir.shape<1> + %2:2 = hlfir.declare %arg0(%1) dummy_scope %0 {uniq_name = "x"} : (!fir.ref>, !fir.shape<1>, !fir.dscope) -> (!fir.ref>, !fir.ref>) + hlfir.forall lb { + hlfir.yield %c1_i64 : i64 + } ub { + hlfir.yield %c10_i64 : i64 + } (%arg1: i64) { + hlfir.region_assign { + %3 = hlfir.designate %2#0 (%c10) : (!fir.ref>, index) -> !fir.ref + %4 = hlfir.designate %3{"p"} {fortran_attrs = #fir.var_attrs} : (!fir.ref) -> !fir.ref i32>> + %5 = fir.load %4 : !fir.ref i32>> + hlfir.yield %5 : !fir.boxproc<() -> i32> + } to { + %3 = hlfir.designate %2#0 (%arg1) : (!fir.ref>, i64) -> !fir.ref + %4 = hlfir.designate %3{"p"} {fortran_attrs = #fir.var_attrs} : (!fir.ref) -> !fir.ref i32>> + hlfir.yield %4 : !fir.ref i32>> + } + } + return +} +// CHECK-LABEL: func.func @test_need_to_save_rhs( +// CHECK: %[[VAL_1:.*]] = fir.alloca i64 +// CHECK: %[[VAL_2:.*]] = fir.alloca !fir.box> +// CHECK: %[[VAL_3:.*]] = fir.alloca i64 +// CHECK: %[[VAL_4:.*]] = arith.constant 10 : i64 +// CHECK: %[[VAL_5:.*]] = arith.constant 1 : i64 +// CHECK: %[[VAL_6:.*]] = arith.constant 10 : index +// CHECK: %[[VAL_7:.*]] = fir.dummy_scope : !fir.dscope +// CHECK: %[[VAL_8:.*]] = fir.shape %[[VAL_6]] : (index) -> !fir.shape<1> +// CHECK: %[[VAL_9:.*]]:2 = hlfir.declare{{.*}}x +// CHECK: %[[VAL_10:.*]] = fir.convert %[[VAL_5]] : (i64) -> index +// CHECK: %[[VAL_11:.*]] = fir.convert %[[VAL_4]] : (i64) -> index +// CHECK: %[[VAL_12:.*]] = arith.constant 1 : index +// CHECK: %[[VAL_13:.*]] = arith.constant 0 : i64 +// CHECK: %[[VAL_14:.*]] = arith.constant 1 : i64 +// CHECK: fir.store %[[VAL_13]] to %[[VAL_3]] : !fir.ref +// CHECK: %[[VAL_19:.*]] = fir.call @_FortranACreateValueStack( +// CHECK: fir.do_loop %[[VAL_20:.*]] = %[[VAL_10]] to %[[VAL_11]] step %[[VAL_12]] { +// CHECK: %[[VAL_21:.*]] = fir.convert %[[VAL_20]] : (index) -> i64 +// CHECK: %[[VAL_22:.*]] = hlfir.designate %[[VAL_9]]#0 (%[[VAL_6]]) : (!fir.ref i32>}>>>, index) -> !fir.ref i32>}>> +// CHECK: %[[VAL_23:.*]] = hlfir.designate %[[VAL_22]]{"p"} {fortran_attrs = #fir.var_attrs} : (!fir.ref i32>}>>) -> !fir.ref i32>> +// CHECK: %[[VAL_24:.*]] = fir.load %[[VAL_23]] : !fir.ref i32>> +// CHECK: %[[VAL_25:.*]] = fir.box_addr %[[VAL_24]] : (!fir.boxproc<() -> i32>) -> (() -> i32) +// CHECK: %[[VAL_26:.*]] = fir.convert %[[VAL_25]] : (() -> i32) -> i64 +// CHECK: fir.store %[[VAL_26]] to %[[VAL_1]] : !fir.ref +// CHECK: %[[VAL_27:.*]] = fir.embox %[[VAL_1]] : (!fir.ref) -> !fir.box +// CHECK: %[[VAL_28:.*]] = fir.convert %[[VAL_27]] : (!fir.box) -> !fir.box +// CHECK: fir.call @_FortranAPushValue(%[[VAL_19]], %[[VAL_28]]) : (!fir.llvm_ptr, !fir.box) -> () +// CHECK: } +// CHECK: %[[VAL_29:.*]] = fir.convert %[[VAL_5]] : (i64) -> index +// CHECK: %[[VAL_30:.*]] = fir.convert %[[VAL_4]] : (i64) -> index +// CHECK: %[[VAL_31:.*]] = arith.constant 1 : index +// CHECK: fir.store %[[VAL_13]] to %[[VAL_3]] : !fir.ref +// CHECK: fir.do_loop %[[VAL_32:.*]] = %[[VAL_29]] to %[[VAL_30]] step %[[VAL_31]] { +// CHECK: %[[VAL_33:.*]] = fir.convert %[[VAL_32]] : (index) -> i64 +// CHECK: %[[VAL_34:.*]] = hlfir.designate %[[VAL_9]]#0 (%[[VAL_33]]) : (!fir.ref i32>}>>>, i64) -> !fir.ref i32>}>> +// CHECK: %[[VAL_35:.*]] = hlfir.designate %[[VAL_34]]{"p"} {fortran_attrs = #fir.var_attrs} : (!fir.ref i32>}>>) -> !fir.ref i32>> +// CHECK: %[[VAL_36:.*]] = fir.load %[[VAL_3]] : !fir.ref +// CHECK: %[[VAL_37:.*]] = arith.addi %[[VAL_36]], %[[VAL_14]] : i64 +// CHECK: fir.store %[[VAL_37]] to %[[VAL_3]] : !fir.ref +// CHECK: %[[VAL_38:.*]] = fir.convert %[[VAL_2]] : (!fir.ref>>) -> !fir.ref> +// CHECK: fir.call @_FortranAValueAt(%[[VAL_19]], %[[VAL_36]], %[[VAL_38]]) : (!fir.llvm_ptr, i64, !fir.ref>) -> () +// CHECK: %[[VAL_39:.*]] = fir.load %[[VAL_2]] : !fir.ref>> +// CHECK: %[[VAL_40:.*]] = fir.box_addr %[[VAL_39]] : (!fir.box>) -> !fir.heap +// CHECK: %[[VAL_41:.*]] = fir.load %[[VAL_40]] : !fir.heap +// CHECK: %[[VAL_42:.*]] = fir.convert %[[VAL_41]] : (i64) -> (() -> i32) +// CHECK: %[[VAL_43:.*]] = fir.emboxproc %[[VAL_42]] : (() -> i32) -> !fir.boxproc<() -> i32> +// CHECK: fir.store %[[VAL_43]] to %[[VAL_35]] : !fir.ref i32>> +// CHECK: } +// CHECK: fir.call @_FortranADestroyValueStack(%[[VAL_19]]) : (!fir.llvm_ptr) -> () +// CHECK: return +// CHECK: } + +func.func @test_need_to_save_lhs(%arg0: !fir.ref>) { + %c11_i64 = arith.constant 11 : i64 + %c10_i64 = arith.constant 10 : i64 + %c1_i64 = arith.constant 1 : i64 + %c10 = arith.constant 10 : index + %0 = fir.dummy_scope : !fir.dscope + %1 = fir.shape %c10 : (index) -> !fir.shape<1> + %2:2 = hlfir.declare %arg0(%1) dummy_scope %0 {uniq_name = "x"} : (!fir.ref>, !fir.shape<1>, !fir.dscope) -> (!fir.ref>, !fir.ref>) + hlfir.forall lb { + hlfir.yield %c1_i64 : i64 + } ub { + hlfir.yield %c10_i64 : i64 + } (%arg1: i64) { + hlfir.region_assign { + %3 = fir.address_of(@f1) : () -> i32 + %4 = fir.emboxproc %3 : (() -> i32) -> !fir.boxproc<() -> ()> + hlfir.yield %4 : !fir.boxproc<() -> ()> + } to { + %3 = arith.subi %c11_i64, %arg1 : i64 + %4 = hlfir.designate %2#0 (%3) : (!fir.ref>, i64) -> !fir.ref + %5 = hlfir.designate %4{"p"} {fortran_attrs = #fir.var_attrs} : (!fir.ref) -> !fir.ref i32>> + %6 = fir.load %5 : !fir.ref i32>> + %7 = fir.box_addr %6 : (!fir.boxproc<() -> i32>) -> (() -> i32) + %8 = fir.call %7() proc_attrs : () -> i32 + %9 = fir.convert %8 : (i32) -> i64 + %10 = hlfir.designate %2#0 (%9) : (!fir.ref>, i64) -> !fir.ref + %11 = hlfir.designate %10{"p"} {fortran_attrs = #fir.var_attrs} : (!fir.ref) -> !fir.ref i32>> + hlfir.yield %11 : !fir.ref i32>> + } + } + return +} +// CHECK-LABEL: func.func @test_need_to_save_lhs( +// CHECK: %[[VAL_1:.*]] = fir.alloca i64 +// CHECK: %[[VAL_2:.*]] = fir.alloca !fir.box> +// CHECK: %[[VAL_3:.*]] = fir.alloca i64 +// CHECK: %[[VAL_4:.*]] = arith.constant 11 : i64 +// CHECK: %[[VAL_5:.*]] = arith.constant 10 : i64 +// CHECK: %[[VAL_6:.*]] = arith.constant 1 : i64 +// CHECK: %[[VAL_7:.*]] = arith.constant 10 : index +// CHECK: %[[VAL_8:.*]] = fir.dummy_scope : !fir.dscope +// CHECK: %[[VAL_9:.*]] = fir.shape %[[VAL_7]] : (index) -> !fir.shape<1> +// CHECK: %[[VAL_10:.*]]:2 = hlfir.declare{{.*}}"x" +// CHECK: %[[VAL_11:.*]] = fir.convert %[[VAL_6]] : (i64) -> index +// CHECK: %[[VAL_12:.*]] = fir.convert %[[VAL_5]] : (i64) -> index +// CHECK: %[[VAL_13:.*]] = arith.constant 1 : index +// CHECK: %[[VAL_14:.*]] = arith.constant 0 : i64 +// CHECK: %[[VAL_15:.*]] = arith.constant 1 : i64 +// CHECK: fir.store %[[VAL_14]] to %[[VAL_3]] : !fir.ref +// CHECK: %[[VAL_20:.*]] = fir.call @_FortranACreateValueStack( +// CHECK: fir.do_loop %[[VAL_21:.*]] = %[[VAL_11]] to %[[VAL_12]] step %[[VAL_13]] { +// CHECK: %[[VAL_22:.*]] = fir.convert %[[VAL_21]] : (index) -> i64 +// CHECK: %[[VAL_23:.*]] = arith.subi %[[VAL_4]], %[[VAL_22]] : i64 +// CHECK: %[[VAL_24:.*]] = hlfir.designate %[[VAL_10]]#0 (%[[VAL_23]]) : (!fir.ref i32>}>>>, i64) -> !fir.ref i32>}>> +// CHECK: %[[VAL_25:.*]] = hlfir.designate %[[VAL_24]]{"p"} {fortran_attrs = #fir.var_attrs} : (!fir.ref i32>}>>) -> !fir.ref i32>> +// CHECK: %[[VAL_26:.*]] = fir.load %[[VAL_25]] : !fir.ref i32>> +// CHECK: %[[VAL_27:.*]] = fir.box_addr %[[VAL_26]] : (!fir.boxproc<() -> i32>) -> (() -> i32) +// CHECK: %[[VAL_28:.*]] = fir.call %[[VAL_27]]() proc_attrs : () -> i32 +// CHECK: %[[VAL_29:.*]] = fir.convert %[[VAL_28]] : (i32) -> i64 +// CHECK: %[[VAL_30:.*]] = hlfir.designate %[[VAL_10]]#0 (%[[VAL_29]]) : (!fir.ref i32>}>>>, i64) -> !fir.ref i32>}>> +// CHECK: %[[VAL_31:.*]] = hlfir.designate %[[VAL_30]]{"p"} {fortran_attrs = #fir.var_attrs} : (!fir.ref i32>}>>) -> !fir.ref i32>> +// CHECK: %[[VAL_32:.*]] = fir.convert %[[VAL_31]] : (!fir.ref i32>>) -> i64 +// CHECK: fir.store %[[VAL_32]] to %[[VAL_1]] : !fir.ref +// CHECK: %[[VAL_33:.*]] = fir.embox %[[VAL_1]] : (!fir.ref) -> !fir.box +// CHECK: %[[VAL_34:.*]] = fir.convert %[[VAL_33]] : (!fir.box) -> !fir.box +// CHECK: fir.call @_FortranAPushValue(%[[VAL_20]], %[[VAL_34]]) : (!fir.llvm_ptr, !fir.box) -> () +// CHECK: } +// CHECK: %[[VAL_35:.*]] = fir.convert %[[VAL_6]] : (i64) -> index +// CHECK: %[[VAL_36:.*]] = fir.convert %[[VAL_5]] : (i64) -> index +// CHECK: %[[VAL_37:.*]] = arith.constant 1 : index +// CHECK: fir.store %[[VAL_14]] to %[[VAL_3]] : !fir.ref +// CHECK: fir.do_loop %[[VAL_38:.*]] = %[[VAL_35]] to %[[VAL_36]] step %[[VAL_37]] { +// CHECK: %[[VAL_39:.*]] = fir.convert %[[VAL_38]] : (index) -> i64 +// CHECK: %[[VAL_40:.*]] = fir.load %[[VAL_3]] : !fir.ref +// CHECK: %[[VAL_41:.*]] = arith.addi %[[VAL_40]], %[[VAL_15]] : i64 +// CHECK: fir.store %[[VAL_41]] to %[[VAL_3]] : !fir.ref +// CHECK: %[[VAL_42:.*]] = fir.convert %[[VAL_2]] : (!fir.ref>>) -> !fir.ref> +// CHECK: fir.call @_FortranAValueAt(%[[VAL_20]], %[[VAL_40]], %[[VAL_42]]) : (!fir.llvm_ptr, i64, !fir.ref>) -> () +// CHECK: %[[VAL_43:.*]] = fir.load %[[VAL_2]] : !fir.ref>> +// CHECK: %[[VAL_44:.*]] = fir.box_addr %[[VAL_43]] : (!fir.box>) -> !fir.heap +// CHECK: %[[VAL_45:.*]] = fir.load %[[VAL_44]] : !fir.heap +// CHECK: %[[VAL_46:.*]] = fir.convert %[[VAL_45]] : (i64) -> !fir.ref i32>> +// CHECK: %[[VAL_47:.*]] = fir.address_of(@f1) : () -> i32 +// CHECK: %[[VAL_48:.*]] = fir.emboxproc %[[VAL_47]] : (() -> i32) -> !fir.boxproc<() -> ()> +// CHECK: %[[VAL_49:.*]] = fir.convert %[[VAL_48]] : (!fir.boxproc<() -> ()>) -> !fir.boxproc<() -> i32> +// CHECK: fir.store %[[VAL_49]] to %[[VAL_46]] : !fir.ref i32>> +// CHECK: } +// CHECK: fir.call @_FortranADestroyValueStack(%[[VAL_20]]) : (!fir.llvm_ptr) -> () +// CHECK: return +// CHECK: } + +func.func private @f1() -> i32 attributes {fir.proc_attrs = #fir.proc_attrs} diff --git a/flang/test/HLFIR/order_assignments/forall-proc-pointer-assignment-scheduling-character.f90 b/flang/test/HLFIR/order_assignments/forall-proc-pointer-assignment-scheduling-character.f90 new file mode 100644 index 0000000000000..d2d1939890882 --- /dev/null +++ b/flang/test/HLFIR/order_assignments/forall-proc-pointer-assignment-scheduling-character.f90 @@ -0,0 +1,126 @@ +! Test analysis of character procedure pointer assignments inside FORALL. +! Character procedure gets their own tests because they are tracked differently +! in FIR because of the length of the function result. + +! RUN: bbc -hlfir -o /dev/null -pass-pipeline="builtin.module(lower-hlfir-ordered-assignments)" \ +! RUN: --debug-only=flang-ordered-assignment -flang-dbg-order-assignment-schedule-only -I nw %s 2>&1 | FileCheck %s +! REQUIRES: asserts + +module char_proc_ptr_forall + type :: t + procedure(f1), nopass, pointer :: p + end type +contains + pure character(2) function f1() + f1 = "01" + end function + pure character(2) function f2() + f2 = "02" + end function + pure character(2) function f3() + f3 = "03" + end function + pure character(2) function f4() + f4 = "04" + end function + pure character(2) function f5() + f5 = "05" + end function + pure character(2) function f6() + f6 = "06" + end function + pure character(2) function f7() + f7 = "07" + end function + pure character(2) function f8() + f8 = "08" + end function + pure character(2) function f9() + f9 = "09" + end function + pure character(2) function f10() + f10 = "10" + end function + + integer pure function decode(c) + character(2), intent(in) :: c + decode = modulo(iachar(c(2:2))-49,10)+1 + end function + + subroutine test_no_conflict(x) + type(t) :: x(10) + forall(i=1:10) x(i)%p => f1 + end subroutine +! CHECK: ------------ scheduling forall in _QMchar_proc_ptr_forallPtest_no_conflict ------------ +! CHECK-NEXT: run 1 evaluate: forall/region_assign1 + + subroutine test_need_to_save_rhs(x) + type(t) :: x(10) + forall(i=1:10) x(i)%p => x(11-i)%p + end subroutine +! CHECK: ------------ scheduling forall in _QMchar_proc_ptr_forallPtest_need_to_save_rhs ------------ +! CHECK-NEXT: conflict: R/W +! CHECK-NEXT: run 1 save : forall/region_assign1/rhs +! CHECK-NEXT: run 2 evaluate: forall/region_assign1 + + subroutine test_need_to_save_lhs(x) + type(t) :: x(10) + forall(i=1:10) x(decode(x(11-i)%p()))%p => f1 + end subroutine +! CHECK: ------------ scheduling forall in _QMchar_proc_ptr_forallPtest_need_to_save_lhs ------------ +! CHECK: conflict: R/W +! CHECK-NEXT: run 1 save : forall/region_assign1/lhs +! CHECK-NEXT: run 2 evaluate: forall/region_assign1 + + subroutine test_need_to_save_lhs_and_rhs(x) + type(t) :: x(10) + forall(i=1:10) x(decode(x(11-i)%p()))%p => x(modulo(-2*i, 11))%p + end subroutine +! CHECK: ------------ scheduling forall in _QMchar_proc_ptr_forallPtest_need_to_save_lhs_and_rhs ------------ +! CHECK: conflict: R/W +! CHECK-NEXT: run 1 save : forall/region_assign1/rhs +! CHECK: conflict: R/W +! CHECK-NEXT: run 1 save : forall/region_assign1/lhs +! CHECK-NEXT: run 2 evaluate: forall/region_assign1 + + +! End-to-end test utilities for debugging purposes. + + subroutine reset(a) + type(t) :: a(:) + a = [t(f10), t(f9), t(f8), t(f7), t(f6), t(f5), t(f4), t(f3), t(f2), t(f1)] + end subroutine + + subroutine print(a) + type(t) :: a(:) + print *, [(decode(a(i)%p()), i=1,10)] + end subroutine + + logical function check_equal(a, expected) + type(t) :: a(:) + integer :: expected(:) + check_equal = all([(decode(a(i)%p()), i=1,10)].eq.expected) + if (.not.check_equal) then + print *, "expected:", expected + print *, "got:", [(decode(a(i)%p()), i=1,10)] + end if + end function +end module + +! End-to-end test for debugging purposes (not verified by lit). + use char_proc_ptr_forall + type(t) :: a(10) + + call reset(a) + call test_need_to_save_rhs(a) + if (.not.check_equal(a, [1, 2, 3, 4, 5, 6, 7, 8, 9, 10])) stop 1 + + call reset(a) + call test_need_to_save_lhs(a) + if (.not.check_equal(a, [1, 1, 1, 1, 1, 1, 1, 1, 1, 1])) stop 2 + + call reset(a) + call test_need_to_save_lhs_and_rhs(a) + if (.not.check_equal(a, [2, 4, 6, 8, 10, 1, 3, 5, 7, 9])) stop 3 + print *, "PASS" +end diff --git a/flang/test/HLFIR/order_assignments/forall-proc-pointer-assignment-scheduling.f90 b/flang/test/HLFIR/order_assignments/forall-proc-pointer-assignment-scheduling.f90 new file mode 100644 index 0000000000000..ba9c203453d95 --- /dev/null +++ b/flang/test/HLFIR/order_assignments/forall-proc-pointer-assignment-scheduling.f90 @@ -0,0 +1,123 @@ +! Test analysis of procedure pointer assignments inside FORALL. + +! RUN: bbc -hlfir -o /dev/null -pass-pipeline="builtin.module(lower-hlfir-ordered-assignments)" \ +! RUN: --debug-only=flang-ordered-assignment -flang-dbg-order-assignment-schedule-only -I nw %s 2>&1 | FileCheck %s +! REQUIRES: asserts + +module proc_ptr_forall + type :: t + procedure(f1), nopass, pointer :: p + end type +contains + pure integer function f1() + f1 = 1 + end function + pure integer function f2() + f2 = 2 + end function + pure integer function f3() + f3 = 3 + end function + pure integer function f4() + f4 = 4 + end function + pure integer function f5() + f5 = 5 + end function + pure integer function f6() + f6 = 6 + end function + pure integer function f7() + f7 = 7 + end function + pure integer function f8() + f8 = 8 + end function + pure integer function f9() + f9 = 9 + end function + pure integer function f10() + f10 = 10 + end function + + subroutine test_no_conflict(x) + type(t) :: x(10) + forall(i=1:10) x(i)%p => f1 + end subroutine +! CHECK: ------------ scheduling forall in _QMproc_ptr_forallPtest_no_conflict ------------ +! CHECK-NEXT: run 1 evaluate: forall/region_assign1 + + subroutine test_need_to_save_rhs(x) + type(t) :: x(10) + forall(i=1:10) x(i)%p => x(11-i)%p + end subroutine +! CHECK: ------------ scheduling forall in _QMproc_ptr_forallPtest_need_to_save_rhs ------------ +! CHECK-NEXT: conflict: R/W +! CHECK-NEXT: run 1 save : forall/region_assign1/rhs +! CHECK-NEXT: run 2 evaluate: forall/region_assign1 + + subroutine test_need_to_save_lhs(x) + type(t) :: x(10) + forall(i=1:10) x(x(11-i)%p())%p => f1 + end subroutine +! CHECK: ------------ scheduling forall in _QMproc_ptr_forallPtest_need_to_save_lhs ------------ +! CHECK-NEXT: unknown effect: %{{.*}} = fir.call +! CHECK-NEXT: unknown effect: %{{.*}} = fir.call +! CHECK-NEXT: conflict: R/W +! CHECK-NEXT: run 1 save : forall/region_assign1/lhs +! CHECK-NEXT: run 2 evaluate: forall/region_assign1 + + subroutine test_need_to_save_lhs_and_rhs(x) + type(t) :: x(10) + forall(i=1:10) x(x(11-i)%p())%p => x(modulo(-2*i, 11))%p + end subroutine +! CHECK: ------------ scheduling forall in _QMproc_ptr_forallPtest_need_to_save_lhs_and_rhs ------------ +! CHECK-NEXT: unknown effect: %{{.*}} = fir.call +! CHECK-NEXT: conflict: R/W +! CHECK-NEXT: run 1 save : forall/region_assign1/rhs +! CHECK-NEXT: unknown effect: %{{.*}} = fir.call +! CHECK-NEXT: conflict: R/W +! CHECK-NEXT: run 1 save : forall/region_assign1/lhs +! CHECK-NEXT: run 2 evaluate: forall/region_assign1 + + +! End-to-end test utilities for debugging purposes. + + subroutine reset(a) + type(t) :: a(:) + a = [t(f10), t(f9), t(f8), t(f7), t(f6), t(f5), t(f4), t(f3), t(f2), t(f1)] + end subroutine + + subroutine print(a) + type(t) :: a(:) + print *, [(a(i)%p(), i=1,10)] + end subroutine + + logical function check_equal(a, expected) + type(t) :: a(:) + integer :: expected(:) + check_equal = all([(a(i)%p(), i=1,10)].eq.expected) + if (.not.check_equal) then + print *, "expected:", expected + print *, "got:", [(a(i)%p(), i=1,10)] + end if + end function +end module + +! End-to-end test for debugging purposes (not verified by lit). + use proc_ptr_forall + type(t) :: a(10) + + call reset(a) + call test_need_to_save_rhs(a) + if (.not.check_equal(a, [1, 2, 3, 4, 5, 6, 7, 8, 9, 10])) stop 1 + + call reset(a) + call test_need_to_save_lhs(a) + if (.not.check_equal(a, [1, 1, 1, 1, 1, 1, 1, 1, 1, 1])) stop 2 + + call reset(a) + call test_need_to_save_lhs_and_rhs(a) + if (.not.check_equal(a, [2, 4, 6, 8, 10, 1, 3, 5, 7, 9])) stop 3 + print *, "PASS" +end