diff --git a/flang/lib/Lower/ConvertCall.cpp b/flang/lib/Lower/ConvertCall.cpp --- a/flang/lib/Lower/ConvertCall.cpp +++ b/flang/lib/Lower/ConvertCall.cpp @@ -1659,9 +1659,13 @@ // use. return res; }; + mlir::Value polymorphicMold; + if (fir::isPolymorphicType(*callContext.resultType)) + polymorphicMold = + impl().getPolymorphicResultMold(loweredActuals, callContext); mlir::Value elemental = hlfir::genElementalOp(loc, builder, elementType, shape, typeParams, - genKernel, !mustBeOrdered); + genKernel, !mustBeOrdered, polymorphicMold); fir::FirOpBuilder *bldr = &builder; callContext.stmtCtx.attachCleanup( [=]() { bldr->create(loc, elemental); }); @@ -1710,6 +1714,14 @@ "compute elemental function result length parameters in HLFIR"); } + mlir::Value getPolymorphicResultMold( + Fortran::lower::PreparedActualArguments &loweredActuals, + CallContext &callContext) { + fir::emitFatalError(callContext.loc, + "elemental function call with polymorphic result"); + return {}; + } + private: Fortran::lower::CallerInterface &caller; mlir::FunctionType callSiteType; @@ -1752,6 +1764,25 @@ "compute elemental character min/max function result length in HLFIR"); } + mlir::Value getPolymorphicResultMold( + Fortran::lower::PreparedActualArguments &loweredActuals, + CallContext &callContext) { + if (!intrinsic) + return {}; + + if (intrinsic->name == "merge") { + // MERGE seems to be the only elemental function that can produce + // polymorphic result. The MERGE's result is polymorphic iff + // both TSOURCE and FSOURCE are polymorphic, and they also must have + // the same declared and dynamic types. So any of them can be used + // for the mold. + assert(!loweredActuals.empty()); + return loweredActuals.front()->getOriginalActual(); + } + + return {}; + } + private: const Fortran::evaluate::SpecificIntrinsic *intrinsic; const fir::IntrinsicArgumentLoweringRules *argLowering; diff --git a/flang/test/Lower/HLFIR/elemental-polymorphic-merge.f90 b/flang/test/Lower/HLFIR/elemental-polymorphic-merge.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Lower/HLFIR/elemental-polymorphic-merge.f90 @@ -0,0 +1,38 @@ +! Test that the produced hlfir.elemental had proper result type and the mold. +! RUN: bbc --emit-hlfir --polymorphic-type -I nowhere -o - %s | FileCheck %s + +subroutine test_polymorphic_merge(x, y, r, m) + type t + end type t + class(t), allocatable :: r(:) + class(t), intent(in) :: y(:), x + logical :: m(:) + r = merge(x, y, m) +end subroutine test_polymorphic_merge +! CHECK-LABEL: func.func @_QPtest_polymorphic_merge( +! CHECK-SAME: %[[VAL_0:.*]]: !fir.class> {fir.bindc_name = "x"}, +! CHECK-SAME: %[[VAL_1:.*]]: !fir.class>> {fir.bindc_name = "y"}, +! CHECK-SAME: %[[VAL_2:.*]]: !fir.ref>>>> {fir.bindc_name = "r"}, +! CHECK-SAME: %[[VAL_3:.*]]: !fir.box>> {fir.bindc_name = "m"}) { +! CHECK: %[[VAL_4:.*]]:2 = hlfir.declare %[[VAL_3]] {uniq_name = "_QFtest_polymorphic_mergeEm"} : (!fir.box>>) -> (!fir.box>>, !fir.box>>) +! CHECK: %[[VAL_5:.*]]:2 = hlfir.declare %[[VAL_2]] {fortran_attrs = #fir.var_attrs, uniq_name = "_QFtest_polymorphic_mergeEr"} : (!fir.ref>>>>) -> (!fir.ref>>>>, !fir.ref>>>>) +! CHECK: %[[VAL_6:.*]]:2 = hlfir.declare %[[VAL_0]] {fortran_attrs = #fir.var_attrs, uniq_name = "_QFtest_polymorphic_mergeEx"} : (!fir.class>) -> (!fir.class>, !fir.class>) +! CHECK: %[[VAL_7:.*]]:2 = hlfir.declare %[[VAL_1]] {fortran_attrs = #fir.var_attrs, uniq_name = "_QFtest_polymorphic_mergeEy"} : (!fir.class>>) -> (!fir.class>>, !fir.class>>) +! CHECK: %[[VAL_8:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_9:.*]]:3 = fir.box_dims %[[VAL_7]]#0, %[[VAL_8]] : (!fir.class>>, index) -> (index, index, index) +! CHECK: %[[VAL_10:.*]] = fir.shape %[[VAL_9]]#1 : (index) -> !fir.shape<1> +! CHECK: %[[VAL_11:.*]] = hlfir.elemental %[[VAL_10]] mold %[[VAL_6]]#0 unordered : (!fir.shape<1>, !fir.class>) -> !hlfir.expr?> { +! CHECK: ^bb0(%[[VAL_12:.*]]: index): +! CHECK: %[[VAL_13:.*]] = hlfir.designate %[[VAL_7]]#0 (%[[VAL_12]]) : (!fir.class>>, index) -> !fir.class> +! CHECK: %[[VAL_14:.*]] = hlfir.designate %[[VAL_4]]#0 (%[[VAL_12]]) : (!fir.box>>, index) -> !fir.ref> +! CHECK: %[[VAL_15:.*]] = fir.load %[[VAL_14]] : !fir.ref> +! CHECK: %[[VAL_16:.*]] = fir.convert %[[VAL_15]] : (!fir.logical<4>) -> i1 +! CHECK: %[[VAL_17:.*]] = arith.select %[[VAL_16]], %[[VAL_6]]#1, %[[VAL_13]] : !fir.class> +! CHECK: %[[VAL_18:.*]]:2 = hlfir.declare %[[VAL_17]] {uniq_name = ".tmp.intrinsic_result"} : (!fir.class>) -> (!fir.class>, !fir.class>) +! CHECK: %[[VAL_19:.*]] = hlfir.as_expr %[[VAL_18]]#0 : (!fir.class>) -> !hlfir.expr?> +! CHECK: hlfir.yield_element %[[VAL_19]] : !hlfir.expr?> +! CHECK: } +! CHECK: hlfir.assign %[[VAL_11]] to %[[VAL_5]]#0 realloc : !hlfir.expr?>, !fir.ref>>>> +! CHECK: hlfir.destroy %[[VAL_11]] : !hlfir.expr?> +! CHECK: return +! CHECK: }