diff --git a/flang/lib/Lower/ConvertCall.cpp b/flang/lib/Lower/ConvertCall.cpp index 9bbb9468831ad..cf814ecadfe44 100644 --- a/flang/lib/Lower/ConvertCall.cpp +++ b/flang/lib/Lower/ConvertCall.cpp @@ -616,6 +616,9 @@ struct CallContext { std::optional resultType; mlir::Location loc; }; + +using ExvAndCleanup = + std::pair>; } // namespace // Helper to transform a fir::ExtendedValue to an hlfir::EntityWithAttributes. @@ -1179,6 +1182,80 @@ genUserCall(Fortran::lower::PreparedActualArguments &loweredActuals, return extendedValueToHlfirEntity(loc, builder, result, ".tmp.func_result"); } +/// Create an optional dummy argument value from \p entity that may be +/// absent. This can only be called with numerical or logical scalar \p entity. +/// If \p entity is considered absent according to 15.5.2.12 point 1., the +/// returned value is zero (or false), otherwise it is the value of \p entity. +static ExvAndCleanup genOptionalValue(fir::FirOpBuilder &builder, + mlir::Location loc, hlfir::Entity entity, + mlir::Value isPresent) { + mlir::Type eleType = entity.getFortranElementType(); + assert(entity.isScalar() && fir::isa_trivial(eleType) && + "must be a numerical or logical scalar"); + return {builder + .genIfOp(loc, {eleType}, isPresent, + /*withElseRegion=*/true) + .genThen([&]() { + mlir::Value val = + hlfir::loadTrivialScalar(loc, builder, entity); + builder.create(loc, val); + }) + .genElse([&]() { + mlir::Value zero = + fir::factory::createZeroValue(builder, loc, eleType); + builder.create(loc, zero); + }) + .getResults()[0], + std::nullopt}; +} + +/// Create an optional dummy argument address from \p entity that may be +/// absent. If \p entity is considered absent according to 15.5.2.12 point 1., +/// the returned value is a null pointer, otherwise it is the address of \p +/// entity. +static ExvAndCleanup genOptionalAddr(fir::FirOpBuilder &builder, + mlir::Location loc, hlfir::Entity entity, + mlir::Value isPresent) { + auto [exv, cleanup] = hlfir::translateToExtendedValue(loc, builder, entity); + // If it is an exv pointer/allocatable, then it cannot be absent + // because it is passed to a non-pointer/non-allocatable. + if (const auto *box = exv.getBoxOf()) + return {fir::factory::genMutableBoxRead(builder, loc, *box), cleanup}; + // If this is not a POINTER or ALLOCATABLE, then it is already an OPTIONAL + // address and can be passed directly. + return {exv, cleanup}; +} + +/// Create an optional dummy argument address from \p entity that may be +/// absent. If \p entity is considered absent according to 15.5.2.12 point 1., +/// the returned value is an absent fir.box, otherwise it is a fir.box +/// describing \p entity. +static ExvAndCleanup genOptionalBox(fir::FirOpBuilder &builder, + mlir::Location loc, hlfir::Entity entity, + mlir::Value isPresent) { + auto [exv, cleanup] = hlfir::translateToExtendedValue(loc, builder, entity); + + // Non allocatable/pointer optional box -> simply forward + if (exv.getBoxOf()) + return {exv, cleanup}; + + fir::ExtendedValue newExv = exv; + // Optional allocatable/pointer -> Cannot be absent, but need to translate + // unallocated/diassociated into absent fir.box. + if (const auto *box = exv.getBoxOf()) + newExv = fir::factory::genMutableBoxRead(builder, loc, *box); + + // createBox will not do create any invalid memory dereferences if exv is + // absent. The created fir.box will not be usable, but the SelectOp below + // ensures it won't be. + mlir::Value box = builder.createBox(loc, newExv); + mlir::Type boxType = box.getType(); + auto absent = builder.create(loc, boxType); + auto boxOrAbsent = builder.create( + loc, boxType, isPresent, box, absent); + return {fir::BoxValue(boxOrAbsent), cleanup}; +} + /// Lower calls to intrinsic procedures with actual arguments that have been /// pre-lowered but have not yet been prepared according to the interface. static std::optional @@ -1187,6 +1264,11 @@ genIntrinsicRefCore(Fortran::lower::PreparedActualArguments &loweredActuals, const fir::IntrinsicArgumentLoweringRules *argLowering, CallContext &callContext) { llvm::SmallVector operands; + llvm::SmallVector cleanupFns; + auto addToCleanups = [&cleanupFns](std::optional fn) { + if (fn) + cleanupFns.emplace_back(std::move(*fn)); + }; auto &stmtCtx = callContext.stmtCtx; auto &converter = callContext.converter; fir::FirOpBuilder &builder = callContext.getBuilder(); @@ -1196,8 +1278,6 @@ genIntrinsicRefCore(Fortran::lower::PreparedActualArguments &loweredActuals, operands.emplace_back(fir::getAbsentIntrinsicArgument()); continue; } - if (arg.value()->handleDynamicOptional()) - TODO(loc, "intrinsic dynamically optional arguments"); hlfir::Entity actual = arg.value()->getActual(loc, builder); if (!argLowering) { // No argument lowering instruction, lower by value. @@ -1222,6 +1302,37 @@ genIntrinsicRefCore(Fortran::lower::PreparedActualArguments &loweredActuals, // Ad-hoc argument lowering handling. fir::ArgLoweringRule argRules = fir::lowerIntrinsicArgumentAs(*argLowering, arg.index()); + if (arg.value()->handleDynamicOptional()) { + mlir::Value isPresent = arg.value()->getIsPresent(); + switch (argRules.lowerAs) { + case fir::LowerIntrinsicArgAs::Value: { + auto [exv, cleanup] = genOptionalValue(builder, loc, actual, isPresent); + addToCleanups(std::move(cleanup)); + operands.emplace_back(exv); + continue; + } + case fir::LowerIntrinsicArgAs::Addr: { + auto [exv, cleanup] = genOptionalAddr(builder, loc, actual, isPresent); + addToCleanups(std::move(cleanup)); + operands.emplace_back(exv); + continue; + } + case fir::LowerIntrinsicArgAs::Box: { + auto [exv, cleanup] = genOptionalBox(builder, loc, actual, isPresent); + addToCleanups(std::move(cleanup)); + operands.emplace_back(exv); + continue; + } + case fir::LowerIntrinsicArgAs::Inquired: { + auto [exv, cleanup] = + hlfir::translateToExtendedValue(loc, builder, actual); + addToCleanups(std::move(cleanup)); + operands.emplace_back(exv); + continue; + } + } + llvm_unreachable("bad switch"); + } switch (argRules.lowerAs) { case fir::LowerIntrinsicArgAs::Value: operands.emplace_back( @@ -1278,6 +1389,8 @@ genIntrinsicRefCore(Fortran::lower::PreparedActualArguments &loweredActuals, // Let the intrinsic library lower the intrinsic procedure call. auto [resultExv, mustBeFreed] = genIntrinsicCall(builder, loc, intrinsicName, scalarResultType, operands); + for (const hlfir::CleanupFunction &fn : cleanupFns) + fn(); if (!fir::getBase(resultExv)) return std::nullopt; hlfir::EntityWithAttributes resultEntity = extendedValueToHlfirEntity( diff --git a/flang/test/Lower/HLFIR/intrinsic-dynamically-optional.f90 b/flang/test/Lower/HLFIR/intrinsic-dynamically-optional.f90 new file mode 100644 index 0000000000000..923d7735f3ec4 --- /dev/null +++ b/flang/test/Lower/HLFIR/intrinsic-dynamically-optional.f90 @@ -0,0 +1,157 @@ +! RUN: bbc --emit-hlfir %s -o - | FileCheck %s + +! mask argument is dynamically optional, lowered as a box +integer function test_optional_as_box(x, mask) + integer :: x(:) + logical, optional :: mask(:) + test_optional_as_box = iall(x, mask=mask) +end function +! CHECK-LABEL: func.func @_QPtest_optional_as_box( +! CHECK-SAME: %[[X_ARG:.*]]: !fir.box> {fir.bindc_name = "x"}, +! CHECK-SAME: %[[MASK_ARG:.*]]: !fir.box>> {fir.bindc_name = "mask", fir.optional}) -> i32 { +! CHECK: %[[MASK_VAR:.*]]:2 = hlfir.declare %[[MASK_ARG]] +! CHECK: %[[RET_ALLOC:.*]] = fir.alloca i32 {bindc_name = "test_optional_as_box", uniq_name = "_QFtest_optional_as_boxEtest_optional_as_box"} +! CHECK: %[[RET_VAR:.*]]:2 = hlfir.declare %[[RET_ALLOC]] +! CHECK: %[[X_VAR:.*]]:2 = hlfir.declare %[[X_ARG]] +! CHECK: %[[C0:.*]] = arith.constant 0 : index +! CHECK: %[[SRC_LINE:.*]] = fir.address_of({{.*}}) : !fir.ref>) -> !fir.box +! CHECK: %[[VAL_7:.*]] = fir.convert %[[SRC_LINE]] : (!fir.ref>) -> !fir.ref +! CHECK: %[[VAL_8:.*]] = fir.convert %[[C0]] : (index) -> i32 +! CHECK: %[[VAL_9:.*]] = fir.convert %[[MASK_VAR]]#1 : (!fir.box>>) -> !fir.box +! CHECK: %[[RES:.*]] = fir.call @_FortranAIAll4(%[[VAL_6]], %[[VAL_7]], %[[C7]], %[[VAL_8]], %[[VAL_9]]) fastmath : (!fir.box, !fir.ref, i32, i32, !fir.box) -> i32 +! CHECK: hlfir.assign %[[RES]] to %[[RET_VAR]]#0 : i32, !fir.ref +! CHECK: %[[RET:.*]] = fir.load %[[RET_VAR]]#1 : !fir.ref +! CHECK: return %[[RET]] : i32 +! CHECK: } + +! mask argument is dynamically optional, lowered as a box +integer function test_optional_as_box2(x, mask) + integer :: x(:) + logical, allocatable :: mask(:) + test_optional_as_box2 = iall(x, mask=mask) +end function +! CHECK-LABEL: func.func @_QPtest_optional_as_box2( +! CHECK-SAME: %[[X_ARG:.*]]: !fir.box> {fir.bindc_name = "x"}, +! CHECK-SAME: %[[MASK_ARG:.*]]: !fir.ref>>>> {fir.bindc_name = "mask"}) -> i32 { +! CHECK: %[[MASK_VAR:.*]]:2 = hlfir.declare %[[MASK_ARG]] +! CHECK: %[[RET_ALLOC:.*]] = fir.alloca i32 {bindc_name = "test_optional_as_box2", uniq_name = "_QFtest_optional_as_box2Etest_optional_as_box2"} +! CHECK: %[[RET_VAR:.*]]:2 = hlfir.declare %[[RET_ALLOC]] +! CHECK: %[[X_VAR:.*]]:2 = hlfir.declare %[[X_ARG]] +! CHECK: %[[MASK_LD:.*]] = fir.load %[[MASK_VAR]]#1 : !fir.ref>>>> +! CHECK: %[[MASK_ADDR:.*]] = fir.box_addr %[[MASK_LD]] : (!fir.box>>>) -> !fir.heap>> +! CHECK: %[[MASK_INT:.*]] = fir.convert %[[MASK_ADDR]] : (!fir.heap>>) -> i64 +! CHECK: %[[C0_I64:.*]] = arith.constant 0 : i64 +! CHECK: %[[MASK_PRESENT:.*]] = arith.cmpi ne, %[[MASK_INT]], %[[C0_I64]] : i64 +! CHECK: %[[MASK_LD2:.*]] = fir.load %[[MASK_VAR]]#1 : !fir.ref>>>> +! CHECK: %[[C0:.*]] = arith.constant 0 : index +! CHECK: %[[MASK_DIMS:.*]]:3 = fir.box_dims %[[MASK_LD2]], %[[C0]] : (!fir.box>>>, index) -> (index, index, index) +! CHECK: %[[MASK_ADDR2:.*]] = fir.box_addr %[[MASK_LD2]] : (!fir.box>>>) -> !fir.heap>> +! CHECK: %[[MASK_SHAPE:.*]] = fir.shape_shift %[[MASK_DIMS]]#0, %[[MASK_DIMS]]#1 : (index, index) -> !fir.shapeshift<1> +! CHECK: %[[MASK_REBOX:.*]] = fir.embox %[[MASK_ADDR2]](%[[MASK_SHAPE]]) : (!fir.heap>>, !fir.shapeshift<1>) -> !fir.box>> +! CHECK: %[[ABSENT:.*]] = fir.absent !fir.box>> +! CHECK: %[[MASK_SEL:.*]] = arith.select %[[MASK_PRESENT]], %[[MASK_REBOX]], %[[ABSENT]] : !fir.box>> +! CHECK: %[[VAL_16:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_17:.*]] = fir.address_of({{.*}}) : !fir.ref> +! CHECK: %[[VAL_18:.*]] = arith.constant 33 : i32 +! CHECK: %[[VAL_19:.*]] = fir.convert %[[X_VAR]]#1 : (!fir.box>) -> !fir.box +! CHECK: %[[VAL_20:.*]] = fir.convert %[[VAL_17]] : (!fir.ref>) -> !fir.ref +! CHECK: %[[VAL_21:.*]] = fir.convert %[[VAL_16]] : (index) -> i32 +! CHECK: %[[VAL_22:.*]] = fir.convert %[[MASK_SEL]] : (!fir.box>>) -> !fir.box +! CHECK: %[[RES:.*]] = fir.call @_FortranAIAll4(%[[VAL_19]], %[[VAL_20]], %[[VAL_18]], %[[VAL_21]], %[[VAL_22]]) fastmath : (!fir.box, !fir.ref, i32, i32, !fir.box) -> i32 +! CHECK: hlfir.assign %[[RES]] to %[[RET_VAR]]#0 : i32, !fir.ref +! CHECK: %[[RET:.*]] = fir.load %[[RET_VAR]]#1 : !fir.ref +! CHECK: return %[[RET]] : i32 +! CHECK: } + +! imaginary component is dyamically optional, lowered as a value +complex function test_optional_as_value(real, imaginary) + real :: real + real, optional :: imaginary + test_optional_as_value = cmplx(real, imaginary) +end function +! CHECK-LABEL: func.func @_QPtest_optional_as_value( +! CHECK-SAME: %[[REAL_ARG:.*]]: !fir.ref {fir.bindc_name = "real"}, +! CHECK-SAME: %[[IMAG_ARG:.*]]: !fir.ref {fir.bindc_name = "imaginary", fir.optional}) -> !fir.complex<4> { +! CHECK: %[[IMAG_VAR:.*]]:2 = hlfir.declare %[[IMAG_ARG]] +! CHECK: %[[REAL_VAR:.*]]:2 = hlfir.declare %[[REAL_ARG]] +! CHECK: %[[RET_ALLOC:.*]] = fir.alloca !fir.complex<4> {bindc_name = "test_optional_as_value", uniq_name = "_QFtest_optional_as_valueEtest_optional_as_value"} +! CHECK: %[[RET_VAR:.*]]:2 = hlfir.declare %[[RET_ALLOC]] +! CHECK: %[[IS_PRESENT:.*]] = fir.is_present %[[IMAG_VAR]]#0 : (!fir.ref) -> i1 +! CHECK: %[[REAL_LD:.*]] = fir.load %[[REAL_VAR]]#0 : !fir.ref +! CHECK: %[[IMAG_LD:.*]] = fir.if %[[IS_PRESENT]] -> (f32) { +! CHECK: %[[IMAG_PRESENT:.*]] = fir.load %[[IMAG_VAR]]#0 : !fir.ref +! CHECK: fir.result %[[IMAG_PRESENT]] : f32 +! CHECK: } else { +! CHECK: %[[IMAG_ABSENT:.*]] = arith.constant 0.000000e+00 : f32 +! CHECK: fir.result %[[IMAG_ABSENT]] : f32 +! CHECK: } +! CHECK: %[[UNDEF:.*]] = fir.undefined !fir.complex<4> +! CHECK: %[[INS_REAL:.*]] = fir.insert_value %[[UNDEF]], %[[REAL_LD]], [0 : index] : (!fir.complex<4>, f32) -> !fir.complex<4> +! CHECK: %[[INS_IMAG:.*]] = fir.insert_value %[[INS_REAL]], %[[IMAG_LD:.*]], [1 : index] : (!fir.complex<4>, f32) -> !fir.complex<4> +! CHECK: hlfir.assign %[[INS_IMAG]] to %[[RET_VAR]]#0 +! CHECK: %[[RET:.*]] = fir.load %[[RET_VAR]]#1 : !fir.ref> +! CHECK: return %[[RET]] : !fir.complex<4> +! CHECK: } + +! stat argument is dynamically optional, lowered as an address +subroutine test_optional_as_addr + integer, allocatable :: from(:), to(:) + integer, allocatable :: stat + allocate(from(20)) + call move_alloc(from, to, stat) + deallocate(to) +end subroutine +! CHECK-LABEL: func.func @_QPtest_optional_as_addr() { +! CHECK: %[[FROM_STACK:.*]] = fir.alloca !fir.box>> {bindc_name = "from", uniq_name = "_QFtest_optional_as_addrEfrom"} +! CHECK: %[[NULLPTR:.*]] = fir.zero_bits !fir.heap> +! CHECK: %[[C0:.*]] = arith.constant 0 : index +! CHECK: %[[ZERO_SHAPE:.*]] = fir.shape %[[C0]] : (index) -> !fir.shape<1> +! CHECK: %[[ZERO_BOX:.*]] = fir.embox %[[NULLPTR]](%[[ZERO_SHAPE]]) : (!fir.heap>, !fir.shape<1>) -> !fir.box>> +! CHECK: fir.store %[[ZERO_BOX]] to %[[FROM_STACK]] : !fir.ref>>> +! CHECK: %[[FROM_VAR:.*]]:2 = hlfir.declare %[[FROM_STACK]] +! CHECK: %[[STAT_STACK:.*]] = fir.alloca !fir.box> {bindc_name = "stat", uniq_name = "_QFtest_optional_as_addrEstat"} +! CHECK: %[[STAT_NULLPTR:.*]] = fir.zero_bits !fir.heap +! CHECK: %[[STAT_NULLBOX:.*]] = fir.embox %[[STAT_NULLPTR]] : (!fir.heap) -> !fir.box> +! CHECK: fir.store %[[STAT_NULLBOX]] to %[[STAT_STACK]] : !fir.ref>> +! CHECK: %[[STAT_VAR:.*]]:2 = hlfir.declare %[[STAT_STACK]] +! CHECK: %[[TO_STACK:.*]] = fir.alloca !fir.box>> {bindc_name = "to", uniq_name = "_QFtest_optional_as_addrEto"} +! CHECK: %[[TO_NULLPTR:.*]] = fir.zero_bits !fir.heap> +! CHECK: %[[C0_1:.*]] = arith.constant 0 : index +! CHECK: %[[TO_ZERO_SHAPE:.*]] = fir.shape %[[C0_1]] : (index) -> !fir.shape<1> +! CHECK: %[[TO_NULLBOX:.*]] = fir.embox %[[TO_NULLPTR]](%[[TO_ZERO_SHAPE]]) : (!fir.heap>, !fir.shape<1>) -> !fir.box>> +! CHECK: fir.store %[[TO_NULLBOX]] to %[[TO_STACK]] : !fir.ref>>> +! CHECK: %[[TO_VAR:.*]]:2 = hlfir.declare %[[TO_STACK]] +! CHECK: %[[C20_I32:.*]] = arith.constant 20 : i32 +! CHECK: %[[C20:.*]] = fir.convert %[[C20_I32]] : (i32) -> index +! CHECK: %[[C0_2:.*]] = arith.constant 0 : index +! CHECK: %[[CMPI:.*]] = arith.cmpi sgt, %[[C20]], %[[C0_2]] : index +! CHECK: %[[ALLOC_SZ:.*]] = arith.select %[[CMPI]], %[[C20]], %[[C0_2]] : index +! CHECK: %[[FROM_ALLOC:.*]] = fir.allocmem !fir.array, %[[ALLOC_SZ]] {fir.must_be_heap = true, uniq_name = "_QFtest_optional_as_addrEfrom.alloc"} +! CHECK: %[[FROM_SHAPE:.*]] = fir.shape %[[ALLOC_SZ]] : (index) -> !fir.shape<1> +! CHECK: %[[FROM_BOX:.*]] = fir.embox %[[FROM_ALLOC]](%[[FROM_SHAPE]]) : (!fir.heap>, !fir.shape<1>) -> !fir.box>> +! CHECK: fir.store %[[FROM_BOX]] to %[[FROM_VAR]]#1 : !fir.ref>>> +! CHECK: %[[STAT_BOX:.*]] = fir.load %[[STAT_VAR]]#1 : !fir.ref>> +! CHECK: %[[STAT_ADDR:.*]] = fir.box_addr %[[STAT_BOX]] : (!fir.box>) -> !fir.heap +! CHECK: %[[ABSENT:.*]] = fir.absent !fir.box +! CHECK: %[[TRUE:.*]] = arith.constant true +! CHECK: %[[VAL_25:.*]] = fir.address_of({{.*}}) : !fir.ref> +! CHECK: %[[VAL_26:.*]] = arith.constant {{.*}} : i32 +! CHECK: %[[VAL_27:.*]] = fir.zero_bits !fir.ref +! CHECK: %[[VAL_28:.*]] = fir.convert %[[TO_VAR]]#1 : (!fir.ref>>>) -> !fir.ref> +! CHECK: %[[VAL_29:.*]] = fir.convert %[[FROM_VAR]]#1 : (!fir.ref>>>) -> !fir.ref> +! CHECK: %[[VAL_30:.*]] = fir.convert %[[VAL_25]] : (!fir.ref>) -> !fir.ref +! CHECK: %[[RES:.*]] = fir.call @_FortranAMoveAlloc(%[[VAL_28]], %[[VAL_29]], %[[VAL_27]], %[[TRUE]], %[[ABSENT]], %[[VAL_30]], %[[VAL_26]]) fastmath : (!fir.ref>, !fir.ref>, !fir.ref, i1, !fir.box, !fir.ref, i32) -> i32 +! CHECK: %[[STAT_INT:.*]] = fir.convert %[[STAT_ADDR]] : (!fir.heap) -> i64 +! CHECK: %[[C0_3:.*]] = arith.constant 0 : i64 +! CHECK: %[[STAT_NOT_NULL:.*]] = arith.cmpi ne, %[[STAT_INT]], %[[C0_3]] : i64 +! CHECK: fir.if %[[STAT_NOT_NULL]] { +! CHECK: fir.store %[[RES]] to %[[STAT_ADDR]] : !fir.heap +! CHECK: } +! [...] +! CHECK: return +! CHECK: } + +! TODO: there seem to be no intrinsics with dynamically optional arguments lowered asInquired +