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 @@ -724,12 +724,19 @@ loc, builder, resultExv, ".tmp.intrinsic_result"); // Move result into memory into an hlfir.expr since they are immutable from // that point, and the result storage is some temp. - if (!fir::isa_trivial(resultEntity.getType())) - resultEntity = hlfir::EntityWithAttributes{ - builder - .create(loc, resultEntity, - builder.createBool(loc, mustBeFreed)) - .getResult()}; + if (!fir::isa_trivial(resultEntity.getType())) { + hlfir::AsExprOp asExpr; + // Character/Derived MERGE lowering returns one of its argument address + // (this is the only intrinsic implemented in that way so far). The + // ownership of this address cannot be taken here since it may not be a + // temp. + if (intrinsic.name == "merge") + asExpr = builder.create(loc, resultEntity); + else + asExpr = builder.create( + loc, resultEntity, builder.createBool(loc, mustBeFreed)); + resultEntity = hlfir::EntityWithAttributes{asExpr.getResult()}; + } return resultEntity; } @@ -800,8 +807,19 @@ // Get result length parameters. llvm::SmallVector typeParams; if (elementType.isa() || - fir::isRecordWithTypeParameters(elementType)) - TODO(loc, "compute elemental function result length parameters in HLFIR"); + fir::isRecordWithTypeParameters(elementType)) { + auto charType = elementType.dyn_cast(); + if (charType && charType.hasConstantLen()) + typeParams.push_back(builder.createIntegerConstant( + loc, builder.getIndexType(), charType.getLen())); + else if (charType) + typeParams.push_back(impl().computeDynamicCharacterResultLength( + loweredActuals, callContext)); + else + TODO( + loc, + "compute elemental PDT function result length parameters in HLFIR"); + } auto genKernel = [&](mlir::Location l, fir::FirOpBuilder &b, mlir::ValueRange oneBasedIndices) -> hlfir::Entity { callContext.stmtCtx.pushScope(); @@ -858,6 +876,13 @@ arg.passBy == PassBy::BaseAddressValueAttribute; } + mlir::Value + computeDynamicCharacterResultLength(PreparedActualArguments &loweredActuals, + CallContext &callContext) { + TODO(callContext.loc, + "compute elemental function result length parameters in HLFIR"); + } + private: Fortran::lower::CallerInterface &caller; mlir::FunctionType callSiteType; @@ -886,6 +911,19 @@ return isFunction; } + mlir::Value + computeDynamicCharacterResultLength(PreparedActualArguments &loweredActuals, + CallContext &callContext) { + if (intrinsic.name == "adjustr" || intrinsic.name == "adjustl" || + intrinsic.name == "merge") + return hlfir::genCharLength(callContext.loc, callContext.getBuilder(), + loweredActuals[0].value().actual); + // Character MIN/MAX is the min/max of the arguments length that are + // present. + TODO(callContext.loc, + "compute elemental character min/max function result length in HLFIR"); + } + private: const Fortran::evaluate::SpecificIntrinsic &intrinsic; const Fortran::lower::IntrinsicArgumentLoweringRules *argLowering; diff --git a/flang/lib/Lower/ConvertType.cpp b/flang/lib/Lower/ConvertType.cpp --- a/flang/lib/Lower/ConvertType.cpp +++ b/flang/lib/Lower/ConvertType.cpp @@ -409,6 +409,15 @@ Fortran::lower::LenParameterTy getCharacterLength(const A &expr) { return fir::SequenceType::getUnknownExtent(); } + + template + Fortran::lower::LenParameterTy + getCharacterLength(const Fortran::evaluate::FunctionRef &funcRef) { + if (auto constantLen = toInt64(funcRef.LEN())) + return *constantLen; + return fir::SequenceType::getUnknownExtent(); + } + Fortran::lower::LenParameterTy getCharacterLength(const Fortran::lower::SomeExpr &expr) { // Do not use dynamic type length here. We would miss constant diff --git a/flang/test/Lower/HLFIR/elemental-intrinsics.f90 b/flang/test/Lower/HLFIR/elemental-intrinsics.f90 --- a/flang/test/Lower/HLFIR/elemental-intrinsics.f90 +++ b/flang/test/Lower/HLFIR/elemental-intrinsics.f90 @@ -88,3 +88,65 @@ ! CHECK: } ! CHECK: fir.call ! CHECK: hlfir.destroy %[[VAL_13]] + + +! ----------------------------------------------------------------------------- +! Test elemental character intrinsics with non compile time constant result +! length. +! ----------------------------------------------------------------------------- + +subroutine test_adjustl(x) + character(*) :: x(100) + call bar(adjustl(x)) +end subroutine +! CHECK-LABEL: func.func @_QPtest_adjustl( +! CHECK: %[[VAL_6:.*]]:2 = hlfir.declare %[[VAL_3:.*]](%[[VAL_5:[a-z0-9]*]]) typeparams %[[VAL_2:[a-z0-9]*]]#1 {{.*}}Ex +! CHECK: %[[VAL_7:.*]] = hlfir.elemental %[[VAL_5]] typeparams %[[VAL_2]]#1 : (!fir.shape<1>, index) -> !hlfir.expr<100x!fir.char<1,?>> { +! CHECK: ^bb0(%[[VAL_8:.*]]: index): +! CHECK: %[[VAL_9:.*]] = hlfir.designate %[[VAL_6]]#0 (%[[VAL_8]]) typeparams %[[VAL_2]]#1 : (!fir.box>>, index, index) -> !fir.boxchar<1> +! CHECK: fir.call @_FortranAAdjustl +! CHECK: %[[VAL_24:.*]]:2 = hlfir.declare %{{.*}} typeparams %[[VAL_22:.*]] {uniq_name = ".tmp.intrinsic_result"} : (!fir.heap>, index) -> (!fir.boxchar<1>, !fir.heap>) +! CHECK: %[[VAL_25:.*]] = arith.constant true +! CHECK: %[[VAL_26:.*]] = hlfir.as_expr %[[VAL_24]]#0 move %[[VAL_25]] : (!fir.boxchar<1>, i1) -> !hlfir.expr> +! CHECK: hlfir.yield_element %[[VAL_26]] : !hlfir.expr> +! CHECK: } + +subroutine test_adjustr(x) + character(*) :: x(100) + call bar(adjustr(x)) +end subroutine +! CHECK-LABEL: func.func @_QPtest_adjustr( +! CHECK: %[[VAL_6:.*]]:2 = hlfir.declare %[[VAL_3:.*]](%[[VAL_5:[a-z0-9]*]]) typeparams %[[VAL_2:[a-z0-9]*]]#1 {{.*}}Ex +! CHECK: %[[VAL_7:.*]] = hlfir.elemental %[[VAL_5]] typeparams %[[VAL_2]]#1 : (!fir.shape<1>, index) -> !hlfir.expr<100x!fir.char<1,?>> { +! CHECK: ^bb0(%[[VAL_8:.*]]: index): +! CHECK: %[[VAL_9:.*]] = hlfir.designate %[[VAL_6]]#0 (%[[VAL_8]]) typeparams %[[VAL_2]]#1 : (!fir.box>>, index, index) -> !fir.boxchar<1> +! CHECK: fir.call @_FortranAAdjustr +! CHECK: %[[VAL_24:.*]]:2 = hlfir.declare %{{.*}} typeparams %[[VAL_22:.*]] {uniq_name = ".tmp.intrinsic_result"} : (!fir.heap>, index) -> (!fir.boxchar<1>, !fir.heap>) +! CHECK: %[[VAL_25:.*]] = arith.constant true +! CHECK: %[[VAL_26:.*]] = hlfir.as_expr %[[VAL_24]]#0 move %[[VAL_25]] : (!fir.boxchar<1>, i1) -> !hlfir.expr> +! CHECK: hlfir.yield_element %[[VAL_26]] : !hlfir.expr> +! CHECK: } + +subroutine test_merge(x, y, mask) + character(*) :: x(100), y(100) + logical :: mask(100) + call bar(merge(x, y, mask)) +end subroutine +! CHECK-LABEL: func.func @_QPtest_merge( +! CHECK: %[[VAL_5:.*]]:2 = hlfir.declare %[[VAL_2:[a-z0-9]*]](%[[VAL_4:[a-z0-9]*]]) {{.*}}Emask +! CHECK: %[[VAL_10:.*]]:2 = hlfir.declare %[[VAL_7:[a-z0-9]*]](%[[VAL_9:[a-z0-9]*]]) typeparams %[[VAL_6:[a-z0-9]*]]#1 {{.*}}Ex +! CHECK: %[[VAL_15:.*]]:2 = hlfir.declare %[[VAL_12:[a-z0-9]*]](%[[VAL_14:[a-z0-9]*]]) typeparams %[[VAL_11:[a-z0-9]*]]#1 {{.*}}Ey +! CHECK: %[[VAL_16:.*]] = hlfir.elemental %[[VAL_9]] typeparams %[[VAL_6]]#1 : (!fir.shape<1>, index) -> !hlfir.expr<100x!fir.char<1,?>> { +! CHECK: ^bb0(%[[VAL_17:.*]]: index): +! CHECK: %[[VAL_18:.*]] = hlfir.designate %[[VAL_10]]#0 (%[[VAL_17]]) typeparams %[[VAL_6]]#1 : (!fir.box>>, index, index) -> !fir.boxchar<1> +! CHECK: %[[VAL_19:.*]] = hlfir.designate %[[VAL_15]]#0 (%[[VAL_17]]) typeparams %[[VAL_11]]#1 : (!fir.box>>, index, index) -> !fir.boxchar<1> +! CHECK: %[[VAL_20:.*]] = hlfir.designate %[[VAL_5]]#0 (%[[VAL_17]]) : (!fir.ref>>, index) -> !fir.ref> +! CHECK: %[[VAL_21:.*]]:2 = fir.unboxchar %[[VAL_18]] : (!fir.boxchar<1>) -> (!fir.ref>, index) +! CHECK: %[[VAL_22:.*]]:2 = fir.unboxchar %[[VAL_19]] : (!fir.boxchar<1>) -> (!fir.ref>, index) +! CHECK: %[[VAL_23:.*]] = fir.load %[[VAL_20]] : !fir.ref> +! CHECK: %[[VAL_24:.*]] = fir.convert %[[VAL_23]] : (!fir.logical<4>) -> i1 +! CHECK: %[[VAL_25:.*]] = arith.select %[[VAL_24]], %[[VAL_21]]#0, %[[VAL_22]]#0 : !fir.ref> +! CHECK: %[[VAL_26:.*]]:2 = hlfir.declare %[[VAL_25]] typeparams %[[VAL_6]]#1 {uniq_name = ".tmp.intrinsic_result"} : (!fir.ref>, index) -> (!fir.boxchar<1>, !fir.ref>) +! CHECK: %[[VAL_27:.*]] = hlfir.as_expr %[[VAL_26]]#0 : (!fir.boxchar<1>) -> !hlfir.expr> +! CHECK: hlfir.yield_element %[[VAL_27]] : !hlfir.expr> +! CHECK: }