diff --git a/flang/lib/Lower/ConvertExpr.cpp b/flang/lib/Lower/ConvertExpr.cpp index d64b28cf7873d..2df4d90482518 100644 --- a/flang/lib/Lower/ConvertExpr.cpp +++ b/flang/lib/Lower/ConvertExpr.cpp @@ -2709,11 +2709,16 @@ class ScalarExprLowering { // select op requires the same type for its two argument, convert // !fir.box to !fir.class when the argument is // polymorphic. - if (fir::isBoxNone(box.getType()) && fir::isPolymorphicType(argTy)) + if (fir::isBoxNone(box.getType()) && fir::isPolymorphicType(argTy)) { box = builder.createConvert( loc, fir::ClassType::get(mlir::NoneType::get(builder.getContext())), box); + } else if (box.getType().isa() && + fir::isPolymorphicType(argTy)) { + box = builder.create(loc, argTy, box, mlir::Value{}, + /*slice=*/mlir::Value{}); + } // Need the box types to be exactly similar for the selectOp. mlir::Value convertedBox = builder.createConvert(loc, argTy, box); @@ -2728,6 +2733,34 @@ class ScalarExprLowering { fir::isPolymorphicType(argTy)) : builder.createBox(getLoc(), genTempExtAddr(*expr), fir::isPolymorphicType(argTy)); + + if (box.getType().isa() && + fir::isPolymorphicType(argTy)) { + // Rebox can only be performed on a present argument. + if (arg.isOptional()) { + mlir::Value isPresent = genActualIsPresentTest(builder, loc, box); + box = + builder + .genIfOp(loc, {argTy}, isPresent, /*withElseRegion=*/true) + .genThen([&]() { + auto rebox = builder + .create( + loc, argTy, box, mlir::Value{}, + /*slice=*/mlir::Value{}) + .getResult(); + builder.create(loc, rebox); + }) + .genElse([&]() { + auto absent = builder.create(loc, argTy) + .getResult(); + builder.create(loc, absent); + }) + .getResults()[0]; + } else { + box = builder.create(loc, argTy, box, mlir::Value{}, + /*slice=*/mlir::Value{}); + } + } caller.placeInput(arg, box); } } else if (arg.passBy == PassBy::AddressAndLength) { diff --git a/flang/lib/Optimizer/CodeGen/CodeGen.cpp b/flang/lib/Optimizer/CodeGen/CodeGen.cpp index 31b6498931b9b..dd5dee8b3a8af 100644 --- a/flang/lib/Optimizer/CodeGen/CodeGen.cpp +++ b/flang/lib/Optimizer/CodeGen/CodeGen.cpp @@ -1346,6 +1346,10 @@ struct EmboxCommonConversion : public FIROpConversion { static bool isDerivedType(fir::BaseBoxType boxTy) { return static_cast(unwrapIfDerived(boxTy)); } + static bool hasAddendum(fir::BaseBoxType boxTy) { + return static_cast(unwrapIfDerived(boxTy)) || + fir::isUnlimitedPolymorphicType(boxTy); + } // Get the element size and CFI type code of the boxed value. std::tuple getSizeAndTypeCode( @@ -1647,6 +1651,7 @@ struct EmboxCommonConversion : public FIROpConversion { mlir::Value typeDesc = {}) const { auto loc = box.getLoc(); auto boxTy = box.getType().dyn_cast(); + auto inputBoxTy = box.getBox().getType().dyn_cast(); llvm::SmallVector typeparams = lenParams; if (!box.getSubstr().empty() && fir::hasDynamicSize(boxTy.getEleTy())) typeparams.push_back(box.getSubstr()[1]); @@ -1654,17 +1659,22 @@ struct EmboxCommonConversion : public FIROpConversion { auto [eleSize, cfiTy] = getSizeAndTypeCode(loc, rewriter, boxTy.getEleTy(), typeparams); - // Reboxing a polymorphic entities. eleSize and type code need to + // Reboxing to a polymorphic entity. eleSize and type code need to // be retrived from the initial box and propagated to the new box. - if (fir::isPolymorphicType(boxTy) && - fir::isPolymorphicType(box.getBox().getType())) { + // If the initial box has an addendum, the type desc must be propagated as + // well. + if (fir::isPolymorphicType(boxTy)) { mlir::Type idxTy = this->lowerTy().indexType(); eleSize = this->getElementSizeFromBox(loc, idxTy, boxTy, loweredBox, rewriter); cfiTy = this->getValueFromBox(loc, boxTy, loweredBox, cfiTy.getType(), rewriter, kTypePosInBox); - typeDesc = this->loadTypeDescAddress(loc, box.getBox().getType(), - loweredBox, rewriter); + // TODO: For initial box that are unlimited polymorphic entities, this + // code must be made conditional because unlimited polymorphic entities + // with intrinsic type spec does not have addendum. + if (hasAddendum(inputBoxTy)) + typeDesc = this->loadTypeDescAddress(loc, box.getBox().getType(), + loweredBox, rewriter); } auto mod = box->template getParentOfType(); diff --git a/flang/test/Lower/polymorphic.f90 b/flang/test/Lower/polymorphic.f90 index ac6ae85bfdf23..52e4498a8d765 100644 --- a/flang/test/Lower/polymorphic.f90 +++ b/flang/test/Lower/polymorphic.f90 @@ -789,6 +789,41 @@ subroutine test_call_with_null() ! CHECK: %[[ARG:.*]] = arith.select %[[IS_ALLOCATED_OR_ASSOCIATED]], %[[CLASS_NONE]], %[[ABSENT]] : !fir.class ! CHECK: fir.call @_QMpolymorphic_testPsub_with_poly_optional(%[[ARG]]) {{.*}} : (!fir.class) -> () + subroutine sub_with_poly_array_optional(a) + class(*), optional :: a(:) + end subroutine + + subroutine test_call_with_pointer_to_optional() + real, pointer :: p(:) + call sub_with_poly_array_optional(p) + end subroutine + +! CHECK-LABEL: func.func @_QMpolymorphic_testPtest_call_with_pointer_to_optional() { +! CHECK: %[[P:.*]] = fir.alloca !fir.box>> {bindc_name = "p", uniq_name = "_QMpolymorphic_testFtest_call_with_pointer_to_optionalEp"} +! CHECK: %[[IS_ALLOCATED_OR_ASSOCIATED:.*]] = arith.cmpi ne +! CHECK: %[[ABSENT:.*]] = fir.absent !fir.class> +! CHECK: %[[LOAD_P:.*]] = fir.load %[[P]] : !fir.ref>>> +! CHECK: %[[REBOX:.*]] = fir.rebox %[[LOAD_P]] : (!fir.box>>) -> !fir.class> +! CHECK: %[[ARG:.*]] = arith.select %[[IS_ALLOCATED_OR_ASSOCIATED]], %[[REBOX]], %[[ABSENT]] : !fir.class> +! CHECK: fir.call @_QMpolymorphic_testPsub_with_poly_array_optional(%[[ARG]]) {{.*}} : (!fir.class>) -> () + + subroutine sub_with_real_pointer_optional(p) + real, optional :: p(:) + call sub_with_poly_array_optional(p) + end subroutine + +! CHECK-LABEL: func.func @_QMpolymorphic_testPsub_with_real_pointer_optional( +! CHECK-SAME: %[[P:.*]]: !fir.box> {fir.bindc_name = "p", fir.optional}) { +! CHECK: %[[IS_PRESENT:.*]] = fir.is_present %[[P]] : (!fir.box>) -> i1 +! CHECK: %[[BOX:.*]] = fir.if %[[IS_PRESENT]] -> (!fir.class>) { +! CHECK: %[[REBOX:.*]] = fir.rebox %[[P]] : (!fir.box>) -> !fir.class> +! CHECK: fir.result %[[REBOX]] : !fir.class> +! CHECK: } else { +! CHECK: %[[ABSENT:.*]] = fir.absent !fir.class> +! CHECK: fir.result %[[ABSENT]] : !fir.class> +! CHECK: } +! CHECK: fir.call @_QMpolymorphic_testPsub_with_poly_array_optional(%[[BOX]]) {{.*}} : (!fir.class>) -> () + end module program test