diff --git a/flang/include/flang/Lower/HlfirIntrinsics.h b/flang/include/flang/Lower/HlfirIntrinsics.h index df1f1ac9a7cf5..088f8bccef4aa 100644 --- a/flang/include/flang/Lower/HlfirIntrinsics.h +++ b/flang/include/flang/Lower/HlfirIntrinsics.h @@ -19,6 +19,8 @@ #define FORTRAN_LOWER_HLFIRINTRINSICS_H #include "flang/Optimizer/Builder/HLFIRTools.h" +#include "flang/Optimizer/Builder/Todo.h" +#include "flang/Optimizer/HLFIR/HLFIROps.h" #include "llvm/ADT/SmallVector.h" #include #include @@ -46,18 +48,71 @@ struct PreparedActualArgument { PreparedActualArgument(hlfir::Entity actual, std::optional isPresent) : actual{actual}, isPresent{isPresent} {} + PreparedActualArgument(hlfir::ElementalAddrOp vectorSubscriptedActual) + : actual{vectorSubscriptedActual}, isPresent{std::nullopt} {} void setElementalIndices(mlir::ValueRange &indices) { oneBasedElementalIndices = &indices; } - hlfir::Entity getActual(mlir::Location loc, - fir::FirOpBuilder &builder) const { - if (oneBasedElementalIndices) - return hlfir::getElementAt(loc, builder, actual, - *oneBasedElementalIndices); - return actual; + + /// Get the prepared actual. If this is an array argument in an elemental + /// call, the current element value will be returned. + hlfir::Entity getActual(mlir::Location loc, fir::FirOpBuilder &builder) const; + + void derefPointersAndAllocatables(mlir::Location loc, + fir::FirOpBuilder &builder) { + if (auto *actualEntity = std::get_if(&actual)) + actual = hlfir::derefPointersAndAllocatables(loc, builder, *actualEntity); + } + + void loadTrivialScalar(mlir::Location loc, fir::FirOpBuilder &builder) { + if (auto *actualEntity = std::get_if(&actual)) + actual = hlfir::loadTrivialScalar(loc, builder, *actualEntity); + } + + /// Ensure an array expression argument is fully evaluated in memory before + /// the call. Useful for impure elemental calls. + hlfir::AssociateOp associateIfArrayExpr(mlir::Location loc, + fir::FirOpBuilder &builder) { + if (auto *actualEntity = std::get_if(&actual)) { + if (!actualEntity->isVariable() && actualEntity->isArray()) { + mlir::Type storageType = actualEntity->getType(); + hlfir::AssociateOp associate = hlfir::genAssociateExpr( + loc, builder, *actualEntity, storageType, "adapt.impure_arg_eval"); + actual = hlfir::Entity{associate}; + return associate; + } + } + return {}; + } + + bool isArray() const { + return std::holds_alternative(actual) || + std::get(actual).isArray(); } - hlfir::Entity getOriginalActual() const { return actual; } - void setOriginalActual(hlfir::Entity newActual) { actual = newActual; } + + mlir::Value genShape(mlir::Location loc, fir::FirOpBuilder &builder) { + if (auto *actualEntity = std::get_if(&actual)) + return hlfir::genShape(loc, builder, *actualEntity); + return std::get(actual).getShape(); + } + + mlir::Value genCharLength(mlir::Location loc, fir::FirOpBuilder &builder) { + if (auto *actualEntity = std::get_if(&actual)) + return hlfir::genCharLength(loc, builder, *actualEntity); + auto typeParams = std::get(actual).getTypeparams(); + assert(typeParams.size() == 1 && + "failed to retrieve vector subscripted character length"); + return typeParams[0]; + } + + /// When the argument is polymorphic, get mold value with the same dynamic + /// type. + mlir::Value getPolymorphicMold(mlir::Location loc) const { + if (auto *actualEntity = std::get_if(&actual)) + return *actualEntity; + TODO(loc, "polymorphic vector subscripts"); + } + bool handleDynamicOptional() const { return isPresent.has_value(); } mlir::Value getIsPresent() const { assert(handleDynamicOptional() && "not a dynamic optional"); @@ -67,7 +122,7 @@ struct PreparedActualArgument { void resetOptionalAspect() { isPresent = std::nullopt; } private: - hlfir::Entity actual; + std::variant actual; mlir::ValueRange *oneBasedElementalIndices{nullptr}; // When the actual may be dynamically optional, "isPresent" // holds a boolean value indicating the presence of the diff --git a/flang/lib/Lower/ConvertCall.cpp b/flang/lib/Lower/ConvertCall.cpp index 169ef71d005cc..90025ba9c687a 100644 --- a/flang/lib/Lower/ConvertCall.cpp +++ b/flang/lib/Lower/ConvertCall.cpp @@ -29,6 +29,7 @@ #include "flang/Optimizer/Builder/Todo.h" #include "flang/Optimizer/Dialect/FIROpsSupport.h" #include "flang/Optimizer/HLFIR/HLFIROps.h" +#include "mlir/IR/IRMapping.h" #include "llvm/Support/CommandLine.h" #include "llvm/Support/Debug.h" #include @@ -1619,37 +1620,33 @@ class ElementalCallBuilder { for (unsigned i = 0; i < numArgs; ++i) { auto &preparedActual = loweredActuals[i]; if (preparedActual) { - hlfir::Entity actual = preparedActual->getOriginalActual(); // Elemental procedure dummy arguments cannot be pointer/allocatables // (C15100), so it is safe to dereference any pointer or allocatable // actual argument now instead of doing this inside the elemental // region. - actual = hlfir::derefPointersAndAllocatables(loc, builder, actual); + preparedActual->derefPointersAndAllocatables(loc, builder); // Better to load scalars outside of the loop when possible. if (!preparedActual->handleDynamicOptional() && impl().canLoadActualArgumentBeforeLoop(i)) - actual = hlfir::loadTrivialScalar(loc, builder, actual); + preparedActual->loadTrivialScalar(loc, builder); // TODO: merge shape instead of using the first one. - if (!shape && actual.isArray()) { + if (!shape && preparedActual->isArray()) { if (preparedActual->handleDynamicOptional()) optionalWithShape = &*preparedActual; else - shape = hlfir::genShape(loc, builder, actual); + shape = preparedActual->genShape(loc, builder); } // 15.8.3 p1. Elemental procedure with intent(out)/intent(inout) // arguments must be called in element order. if (impl().argMayBeModifiedByCall(i)) mustBeOrdered = true; - // Propagates pointer dereferences and scalar loads. - preparedActual->setOriginalActual(actual); } } if (!shape && optionalWithShape) { // If all array operands appear in optional positions, then none of them // is allowed to be absent as per 15.5.2.12 point 3. (6). Just pick the // first operand. - shape = - hlfir::genShape(loc, builder, optionalWithShape->getOriginalActual()); + shape = optionalWithShape->genShape(loc, builder); // TODO: There is an opportunity to add a runtime check here that // this array is present as required. Also, the optionality of all actual // could be checked and reset given the Fortran requirement. @@ -1663,16 +1660,10 @@ class ElementalCallBuilder { // intent(inout) arguments. Note that the scalar arguments are handled // above. if (mustBeOrdered) { - for (unsigned i = 0; i < numArgs; ++i) { - auto &preparedActual = loweredActuals[i]; + for (auto &preparedActual : loweredActuals) { if (preparedActual) { - hlfir::Entity actual = preparedActual->getOriginalActual(); - if (!actual.isVariable() && actual.isArray()) { - mlir::Type storageType = actual.getType(); - hlfir::AssociateOp associate = hlfir::genAssociateExpr( - loc, builder, actual, storageType, "adapt.impure_arg_eval"); - preparedActual->setOriginalActual(hlfir::Entity{associate}); - + if (hlfir::AssociateOp associate = + preparedActual->associateIfArrayExpr(loc, builder)) { fir::FirOpBuilder *bldr = &builder; callContext.stmtCtx.attachCleanup( [=]() { bldr->create(loc, associate); }); @@ -1852,9 +1843,8 @@ class ElementalIntrinsicCallBuilder if (intrinsic) if (intrinsic->name == "adjustr" || intrinsic->name == "adjustl" || intrinsic->name == "merge") - return hlfir::genCharLength( - callContext.loc, callContext.getBuilder(), - loweredActuals[0].value().getOriginalActual()); + return loweredActuals[0].value().genCharLength( + callContext.loc, callContext.getBuilder()); // Character MIN/MAX is the min/max of the arguments length that are // present. TODO(callContext.loc, @@ -1874,7 +1864,7 @@ class ElementalIntrinsicCallBuilder // the same declared and dynamic types. So any of them can be used // for the mold. assert(!loweredActuals.empty()); - return loweredActuals.front()->getOriginalActual(); + return loweredActuals.front()->getPolymorphicMold(callContext.loc); } return {}; @@ -2137,7 +2127,7 @@ genProcedureRef(CallContext &callContext) { Fortran::lower::CallerInterface caller(callContext.procRef, callContext.converter); mlir::FunctionType callSiteType = caller.genFunctionType(); - + const bool isElemental = callContext.isElementalProcWithArrayArgs(); Fortran::lower::PreparedActualArguments loweredActuals; // Lower the actual arguments for (const Fortran::lower::CallInterface< @@ -2162,6 +2152,21 @@ genProcedureRef(CallContext &callContext) { } } + if (isElemental && !arg.hasValueAttribute() && + Fortran::evaluate::IsVariable(*expr) && + Fortran::evaluate::HasVectorSubscript(*expr)) { + // Vector subscripted arguments are copied in calls, except in elemental + // calls without VALUE attribute where Fortran 2018 15.5.2.4 point 21 + // does not apply and the address of each element must be passed. + hlfir::ElementalAddrOp elementalAddr = + Fortran::lower::convertVectorSubscriptedExprToElementalAddr( + loc, callContext.converter, *expr, callContext.symMap, + callContext.stmtCtx); + loweredActuals.emplace_back( + Fortran::lower::PreparedActualArgument{elementalAddr}); + continue; + } + auto loweredActual = Fortran::lower::convertExprToHLFIR( loc, callContext.converter, *expr, callContext.symMap, callContext.stmtCtx); @@ -2178,7 +2183,7 @@ genProcedureRef(CallContext &callContext) { // Optional dummy argument for which there is no actual argument. loweredActuals.emplace_back(std::nullopt); } - if (callContext.isElementalProcWithArrayArgs()) { + if (isElemental) { bool isImpure = false; if (const Fortran::semantics::Symbol *procSym = callContext.procRef.proc().GetSymbol()) @@ -2189,6 +2194,27 @@ genProcedureRef(CallContext &callContext) { return genUserCall(loweredActuals, caller, callSiteType, callContext); } +hlfir::Entity Fortran::lower::PreparedActualArgument::getActual( + mlir::Location loc, fir::FirOpBuilder &builder) const { + if (auto *actualEntity = std::get_if(&actual)) { + if (oneBasedElementalIndices) + return hlfir::getElementAt(loc, builder, *actualEntity, + *oneBasedElementalIndices); + return *actualEntity; + } + assert(oneBasedElementalIndices && "expect elemental context"); + hlfir::ElementalAddrOp elementalAddr = + std::get(actual); + mlir::IRMapping mapper; + auto alwaysFalse = [](hlfir::ElementalOp) -> bool { return false; }; + mlir::Value addr = hlfir::inlineElementalOp( + loc, builder, elementalAddr, *oneBasedElementalIndices, mapper, + /*mustRecursivelyInline=*/alwaysFalse); + assert(elementalAddr.getCleanup().empty() && "no clean-up expected"); + elementalAddr.erase(); + return hlfir::Entity{addr}; +} + bool Fortran::lower::isIntrinsicModuleProcRef( const Fortran::evaluate::ProcedureRef &procRef) { const Fortran::semantics::Symbol *symbol = procRef.proc().GetSymbol(); diff --git a/flang/lib/Lower/HlfirIntrinsics.cpp b/flang/lib/Lower/HlfirIntrinsics.cpp index 20e570044e8d4..9f764b6142522 100644 --- a/flang/lib/Lower/HlfirIntrinsics.cpp +++ b/flang/lib/Lower/HlfirIntrinsics.cpp @@ -152,7 +152,7 @@ mlir::Value HlfirTransformationalIntrinsic::loadBoxAddress( if (!arg) return mlir::Value{}; - hlfir::Entity actual = arg->getOriginalActual(); + hlfir::Entity actual = arg->getActual(loc, builder); if (!arg->handleDynamicOptional()) { if (actual.isMutableBox()) { @@ -193,7 +193,7 @@ llvm::SmallVector HlfirTransformationalIntrinsic::getOperandVector( operands.emplace_back(); continue; } - hlfir::Entity actual = arg->getOriginalActual(); + hlfir::Entity actual = arg->getActual(loc, builder); mlir::Value valArg; if (!argLowering) { diff --git a/flang/test/Lower/HLFIR/elemental-call-vector-subscripts.f90 b/flang/test/Lower/HLFIR/elemental-call-vector-subscripts.f90 new file mode 100644 index 0000000000000..b8f7ee9338fbd --- /dev/null +++ b/flang/test/Lower/HLFIR/elemental-call-vector-subscripts.f90 @@ -0,0 +1,93 @@ +! Test passing of vector subscripted entities inside elemental +! procedures. +! RUN: bbc --emit-hlfir -o - %s | FileCheck %s + +subroutine test() + interface + elemental subroutine foo(x, y) + real, intent(in) :: x + real, value :: y + end subroutine + end interface + real :: x(10) + call foo(x([1,3,7]), 0.) +end subroutine +! CHECK-LABEL: func.func @_QPtest() { +! CHECK: %[[VAL_0:.*]] = arith.constant 10 : index +! CHECK: %[[VAL_1:.*]] = fir.alloca !fir.array<10xf32> {bindc_name = "x", uniq_name = "_QFtestEx"} +! CHECK: %[[VAL_2:.*]] = fir.shape %[[VAL_0]] : (index) -> !fir.shape<1> +! CHECK: %[[VAL_3:.*]]:2 = hlfir.declare %[[VAL_1]](%[[VAL_2]]) {uniq_name = "_QFtestEx"} : (!fir.ref>, !fir.shape<1>) -> (!fir.ref>, !fir.ref>) +! CHECK: %[[VAL_4:.*]] = fir.address_of(@_QQro.3xi8.0) : !fir.ref> +! CHECK: %[[VAL_5:.*]] = arith.constant 3 : index +! CHECK: %[[VAL_6:.*]] = fir.shape %[[VAL_5]] : (index) -> !fir.shape<1> +! CHECK: %[[VAL_7:.*]]:2 = hlfir.declare %[[VAL_4]](%[[VAL_6]]) +! CHECK: %[[VAL_8:.*]] = arith.constant 3 : index +! CHECK: %[[VAL_9:.*]] = arith.constant 0.000000e+00 : f32 +! CHECK: %[[VAL_10:.*]] = arith.constant 1 : index +! CHECK: fir.do_loop %[[VAL_11:.*]] = %[[VAL_10]] to %[[VAL_8]] step %[[VAL_10]] unordered { +! CHECK: %[[VAL_12:.*]] = hlfir.designate %[[VAL_7]]#0 (%[[VAL_11]]) : (!fir.ref>, index) -> !fir.ref +! CHECK: %[[VAL_13:.*]] = fir.load %[[VAL_12]] : !fir.ref +! CHECK: %[[VAL_14:.*]] = hlfir.designate %[[VAL_3]]#0 (%[[VAL_13]]) : (!fir.ref>, i64) -> !fir.ref +! CHECK: fir.call @_QPfoo(%[[VAL_14]], %[[VAL_9]]) {{.*}}: (!fir.ref, f32) -> () +! CHECK: } +! CHECK: return +! CHECK: } + +subroutine test_value() + interface + elemental subroutine foo_value(x, y) + real, value :: x + real, value :: y + end subroutine + end interface + real :: x(10) + call foo_value(x([1,3,7]), 0.) +end subroutine + +! CHECK-LABEL: func.func @_QPtest_value() { +! CHECK: %[[VAL_0:.*]] = arith.constant 10 : index +! CHECK: %[[VAL_1:.*]] = fir.alloca !fir.array<10xf32> {bindc_name = "x", uniq_name = "_QFtest_valueEx"} +! CHECK: %[[VAL_2:.*]] = fir.shape %[[VAL_0]] : (index) -> !fir.shape<1> +! CHECK: %[[VAL_3:.*]]:2 = hlfir.declare %[[VAL_1]](%[[VAL_2]]) {uniq_name = "_QFtest_valueEx"} : (!fir.ref>, !fir.shape<1>) -> (!fir.ref>, !fir.ref>) +! CHECK: %[[VAL_4:.*]] = fir.address_of(@_QQro.3xi8.0) : !fir.ref> +! CHECK: %[[VAL_5:.*]] = arith.constant 3 : index +! CHECK: %[[VAL_6:.*]] = fir.shape %[[VAL_5]] : (index) -> !fir.shape<1> +! CHECK: %[[VAL_7:.*]]:2 = hlfir.declare %[[VAL_4]](%[[VAL_6]]) +! CHECK: %[[VAL_8:.*]] = arith.constant 3 : index +! CHECK: %[[VAL_9:.*]] = fir.shape %[[VAL_8]] : (index) -> !fir.shape<1> +! CHECK: %[[VAL_10:.*]] = hlfir.elemental %[[VAL_9]] unordered : (!fir.shape<1>) -> !hlfir.expr<3xf32> { +! CHECK: ^bb0(%[[VAL_11:.*]]: index): +! CHECK: %[[VAL_12:.*]] = hlfir.designate %[[VAL_7]]#0 (%[[VAL_11]]) : (!fir.ref>, index) -> !fir.ref +! CHECK: %[[VAL_13:.*]] = fir.load %[[VAL_12]] : !fir.ref +! CHECK: %[[VAL_14:.*]] = hlfir.designate %[[VAL_3]]#0 (%[[VAL_13]]) : (!fir.ref>, i64) -> !fir.ref +! CHECK: %[[VAL_15:.*]] = fir.load %[[VAL_14]] : !fir.ref +! CHECK: hlfir.yield_element %[[VAL_15]] : f32 +! CHECK: } +! CHECK: %[[VAL_16:.*]] = arith.constant 0.000000e+00 : f32 +! CHECK: %[[VAL_17:.*]] = arith.constant 1 : index +! CHECK: fir.do_loop %[[VAL_18:.*]] = %[[VAL_17]] to %[[VAL_8]] step %[[VAL_17]] unordered { +! CHECK: %[[VAL_19:.*]] = hlfir.apply %[[VAL_10]], %[[VAL_18]] : (!hlfir.expr<3xf32>, index) -> f32 +! CHECK: fir.call @_QPfoo_value(%[[VAL_19]], %[[VAL_16]]) {{.*}}: (f32, f32) -> () +! CHECK: } +! CHECK: hlfir.destroy %[[VAL_10]] : !hlfir.expr<3xf32> +! CHECK: return + +subroutine test_not_a_variable(i) + interface + elemental subroutine foo2(j) + integer(8), intent(in) :: j + end subroutine + end interface + integer(8) :: i(:) + call foo2((i(i))) +end subroutine +! CHECK-LABEL: func.func @_QPtest_not_a_variable( +! CHECK: hlfir.elemental +! CHECK: %[[VAL_16:.*]] = hlfir.elemental +! CHECK: %[[VAL_20:.*]] = arith.constant 1 : index +! CHECK: fir.do_loop %[[VAL_21:.*]] = {{.*}} +! CHECK: %[[VAL_22:.*]] = hlfir.apply %[[VAL_16]], %[[VAL_21]] : (!hlfir.expr, index) -> i64 +! CHECK: %[[VAL_23:.*]]:3 = hlfir.associate %[[VAL_22]] {uniq_name = "adapt.valuebyref"} : (i64) -> (!fir.ref, !fir.ref, i1) +! CHECK: fir.call @_QPfoo2(%[[VAL_23]]#1){{.*}}: (!fir.ref) -> () +! CHECK: hlfir.end_associate %[[VAL_23]]#1, %[[VAL_23]]#2 : !fir.ref, i1 +! CHECK: }