diff --git a/flang/include/flang/Optimizer/Builder/HLFIRTools.h b/flang/include/flang/Optimizer/Builder/HLFIRTools.h index f96d2228915fe..9f7c10c2b06c2 100644 --- a/flang/include/flang/Optimizer/Builder/HLFIRTools.h +++ b/flang/include/flang/Optimizer/Builder/HLFIRTools.h @@ -98,6 +98,13 @@ class Entity : public mlir::Value { mlir::Type getElementOrSequenceType() const { return hlfir::getFortranElementOrSequenceType(getType()); } + /// Return the fir.class or fir.box type needed to describe this entity. + fir::BaseBoxType getBoxType() const { + if (isBoxAddressOrValue()) + return llvm::cast(fir::unwrapRefType(getType())); + const bool isVolatile = fir::isa_volatile_type(getType()); + return fir::BoxType::get(getElementOrSequenceType(), isVolatile); + } bool hasLengthParameters() const { mlir::Type eleTy = getFortranElementType(); diff --git a/flang/lib/Lower/Bridge.cpp b/flang/lib/Lower/Bridge.cpp index 0595ca063f407..1dd3a673e3ca8 100644 --- a/flang/lib/Lower/Bridge.cpp +++ b/flang/lib/Lower/Bridge.cpp @@ -4732,11 +4732,21 @@ class FirConverter : public Fortran::lower::AbstractConverter { return fir::factory::createUnallocatedBox(*builder, loc, lhsBoxType, {}); hlfir::Entity rhs = Fortran::lower::convertExprToHLFIR( loc, *this, assign.rhs, localSymbols, rhsContext); + auto rhsBoxType = rhs.getBoxType(); // Create pointer descriptor value from the RHS. if (rhs.isMutableBox()) rhs = hlfir::Entity{fir::LoadOp::create(*builder, loc, rhs)}; - mlir::Value rhsBox = hlfir::genVariableBox( - loc, *builder, rhs, lhsBoxType.getBoxTypeWithNewShape(rhs.getRank())); + + // Use LHS type if LHS is not polymorphic. + fir::BaseBoxType targetBoxType; + if (assign.lhs.GetType()->IsPolymorphic()) + targetBoxType = rhsBoxType.getBoxTypeWithNewAttr( + fir::BaseBoxType::Attribute::Pointer); + else + targetBoxType = lhsBoxType.getBoxTypeWithNewShape(rhs.getRank()); + mlir::Value rhsBox = + hlfir::genVariableBox(loc, *builder, rhs, targetBoxType); + // Apply lower bounds or reshaping if any. if (const auto *lbExprs = std::get_if(&assign.u); diff --git a/flang/test/Lower/forall-polymorphic.f90 b/flang/test/Lower/forall-polymorphic.f90 new file mode 100644 index 0000000000000..2b7a51f9b549a --- /dev/null +++ b/flang/test/Lower/forall-polymorphic.f90 @@ -0,0 +1,89 @@ +! Test lower of FORALL polymorphic pointer assignment +! RUN: bbc -emit-fir %s -o - | FileCheck %s + +!! Test when LHS is polymorphic and RHS is not polymorphic +! CHECK-LABEL: c.func @_QPforallpolymorphic + subroutine forallPolymorphic() + TYPE :: DT + CLASS(DT), POINTER :: Ptr(:) => NULL() + END TYPE + + TYPE, EXTENDS(DT) :: DT1 + END TYPE + + TYPE(DT1), TARGET :: Tar1(10) + CLASS(DT), POINTER :: T(:) + integer :: I + + FORALL (I=1:10) + T(I)%Ptr => Tar1 + END FORALL + +! CHECK: %[[V_11:[0-9]+]] = fir.alloca !fir.class>>>}>>>> {bindc_name = "t", uniq_name = "_QFforallpolymorphicEt"} +! CHECK: %[[V_15:[0-9]+]] = fir.declare %[[V_11]] {fortran_attrs = #fir.var_attrs, uniq_name = "_QFforallpolymorphicEt"} : (!fir.ref>>>}>>>>>) -> !fir.ref>>>}>>>>> +! CHECK: %[[V_16:[0-9]+]] = fir.alloca !fir.array<10x!fir.type<_QFforallpolymorphicTdt1{dt:!fir.type<_QFforallpolymorphicTdt{ptr:!fir.class>>>}>}>> {bindc_name = "tar1", fir.target, uniq_name = "_QFforallpolymorphicEtar1"} +! CHECK: %[[V_17:[0-9]+]] = fir.shape %c10 : (index) -> !fir.shape<1> +! CHECK: %[[V_18:[0-9]+]] = fir.declare %[[V_16]](%[[V_17]]) {fortran_attrs = #fir.var_attrs, uniq_name = "_QFforallpolymorphicEtar1"} : (!fir.ref>>>}>}>>>, !fir.shape<1>) -> !fir.ref>>>}>}>>> +! CHECK: %[[V_19:[0-9]+]] = fir.embox %[[V_18]](%[[V_17]]) : (!fir.ref>>>}>}>>>, !fir.shape<1>) -> !fir.box>>>}>}>>> +! CHECK: %[[V_34:[0-9]+]] = fir.convert %c1_i32 : (i32) -> index +! CHECK: %[[V_35:[0-9]+]] = fir.convert %c10_i32 : (i32) -> index +! CHECK: fir.do_loop %arg0 = %[[V_34]] to %[[V_35]] step %c1 +! CHECK: { +! CHECK: %[[V_36:[0-9]+]] = fir.convert %arg0 : (index) -> i32 +! CHECK: %[[V_37:[0-9]+]] = fir.load %[[V_15]] : !fir.ref>>>}>>>>> +! CHECK: %[[V_38:[0-9]+]] = fir.convert %[[V_36]] : (i32) -> i64 +! CHECK: %[[C0:.*]] = arith.constant 0 : index +! CHECK: %[[V_39:[0-9]+]]:3 = fir.box_dims %37, %[[C0]] : (!fir.class>>>}>>>>, index) -> (index, index, index) +! CHECK: %[[V_40:[0-9]+]] = fir.shift %[[V_39]]#0 : (index) -> !fir.shift<1> +! CHECK: %[[V_41:[0-9]+]] = fir.array_coor %[[V_37]](%[[V_40]]) %[[V_38]] : (!fir.class>>>}>>>>, !fir.shift<1>, i64) -> !fir.ref>>>}>> +! CHECK: %[[V_42:[0-9]+]] = fir.embox %[[V_41]] source_box %[[V_37]] : (!fir.ref>>>}>>, !fir.class>>>}>>>>) -> !fir.class>>>}>> +! CHECK: %[[V_43:[0-9]+]] = fir.field_index ptr, !fir.type<_QFforallpolymorphicTdt{ptr:!fir.class>>>}> +! CHECK: %[[V_44:[0-9]+]] = fir.coordinate_of %[[V_42]], ptr : (!fir.class>>>}>>) -> !fir.ref>>>}>>>>> +! CHECK: %[[V_45:[0-9]+]] = fir.embox %[[V_18]](%[[V_17]]) : (!fir.ref>>>}>}>>>, !fir.shape<1>) -> !fir.box>>>}>}>>>> +! CHECK: %[[V_46:[0-9]+]] = fir.convert %[[V_45]] : (!fir.box>>>}>}>>>>) -> !fir.class>>>}>>>> +! CHECK: fir.store %[[V_46]] to %[[V_44]] : !fir.ref>>>}>>>>> +! CHECK: } + + end subroutine forallPolymorphic + +!! Test when LHS is not polymorphic but RHS is polymorphic +! CHECK-LABEL: c.func @_QPforallpolymorphic2( +! CHECK-SAME: %arg0: !fir.ref>>>}>>>>> {fir.bindc_name = "tar1", fir.target}) { + subroutine forallPolymorphic2(Tar1) + TYPE :: DT + TYPE(DT), POINTER :: Ptr(:) => NULL() + END TYPE + + TYPE, EXTENDS(DT) :: DT1 + END TYPE + + CLASS(DT), ALLOCATABLE, TARGET :: Tar1(:) + TYPE(DT) :: T(10) + integer :: I + + FORALL (I=1:10) + T(I)%Ptr => Tar1 + END FORALL + +! CHECK: %[[V_11:[0-9]+]] = fir.alloca !fir.array<10x!fir.type<_QFforallpolymorphic2Tdt{ptr:!fir.box>>>}>> {bindc_name = "t", uniq_name = "_QFforallpolymorphic2Et"} +! CHECK: %[[V_12:[0-9]+]] = fir.shape %c10 : (index) -> !fir.shape<1> +! CHECK: %[[V_13:[0-9]+]] = fir.declare %[[V_11]](%[[V_12]]) {uniq_name = "_QFforallpolymorphic2Et"} : (!fir.ref>>>}>>>, !fir.shape<1>) -> !fir.ref>>>}>>> +! CHECK: %[[V_18:[0-9]+]] = fir.declare %arg0 dummy_scope %0 {fortran_attrs = #fir.var_attrs, uniq_name = "_QFforallpolymorphic2Etar1"} : (!fir.ref>>>}>>>>>, !fir.dscope) -> !fir.ref>>>}>>>>> +! CHECK: %[[V_30:[0-9]+]] = fir.convert %c1_i32 : (i32) -> index +! CHECK: %[[V_31:[0-9]+]] = fir.convert %c10_i32 : (i32) -> index +! CHECK: fir.do_loop %arg1 = %[[V_30]] to %[[V_31]] step %c1 +! CHECK: { +! CHECK: %[[V_32:[0-9]+]] = fir.convert %arg1 : (index) -> i32 +! CHECK: %[[V_33:[0-9]+]] = fir.convert %[[V_32]] : (i32) -> i64 +! CHECK: %[[V_34:[0-9]+]] = fir.array_coor %[[V_13]](%[[V_12]]) %[[V_33]] : (!fir.ref>>>}>>>, !fir.shape<1>, i64) -> !fir.ref>>>}>> +! CHECK: %[[V_35:[0-9]+]] = fir.field_index ptr, !fir.type<_QFforallpolymorphic2Tdt{ptr:!fir.box>>>}> +! CHECK: %[[V_36:[0-9]+]] = fir.coordinate_of %[[V_34]], ptr : (!fir.ref>>>}>>) -> !fir.ref>>>}>>>>> +! CHECK: %[[V_37:[0-9]+]] = fir.load %[[V_18]] : !fir.ref>>>}>>>>> +! CHECK: %[[V_38:[0-9]+]]:3 = fir.box_dims %[[V_37]], %c0 : (!fir.class>>>}>>>>, index) -> (index, index, index) +! CHECK: %[[V_39:[0-9]+]] = fir.shift %[[V_38]]#0 : (index) -> !fir.shift<1> +! CHECK: %[[V_40:[0-9]+]] = fir.rebox %[[V_37]](%[[V_39]]) : (!fir.class>>>}>>>>, !fir.shift<1>) -> !fir.box>>>}>>>> +! CHECK: fir.store %[[V_40]] to %[[V_36]] : !fir.ref>>>}>>>>> +! CHECK: } + + end subroutine forallPolymorphic2 +