diff --git a/flang/lib/Lower/ConvertExpr.cpp b/flang/lib/Lower/ConvertExpr.cpp --- a/flang/lib/Lower/ConvertExpr.cpp +++ b/flang/lib/Lower/ConvertExpr.cpp @@ -568,6 +568,25 @@ fir::emitFatalError(getLoc(), "NULL() must be lowered in its context"); } + /// A `NULL()` in a position where a mutable box is expected has the same + /// semantics as an absent optional box value. + ExtValue genMutableBoxValueImpl(const Fortran::evaluate::NullPointer &) { + mlir::Location loc = getLoc(); + auto nullConst = builder.createNullConstant(loc); + auto noneTy = mlir::NoneType::get(builder.getContext()); + auto polyRefTy = fir::LLVMPointerType::get(noneTy); + // MutableBoxValue will dereference the box, so create a bogus temporary for + // the `nullptr`. The LLVM optimizer will garbage collect the temp. + auto temp = + builder.createTemporary(loc, polyRefTy, /*shape=*/mlir::ValueRange{}); + auto nullPtr = builder.createConvert(loc, polyRefTy, nullConst); + builder.create(loc, nullPtr, temp); + auto nullBoxTy = builder.getRefType(fir::BoxType::get(noneTy)); + return fir::MutableBoxValue(builder.createConvert(loc, nullBoxTy, temp), + /*lenParameters=*/mlir::ValueRange{}, + /*mutableProperties=*/{}); + } + template ExtValue genMutableBoxValueImpl(const Fortran::evaluate::FunctionRef &funRef) { diff --git a/flang/test/Lower/dummy-argument-contiguous.f90 b/flang/test/Lower/dummy-argument-contiguous.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Lower/dummy-argument-contiguous.f90 @@ -0,0 +1,140 @@ +! RUN: bbc -emit-fir %s -o - | FileCheck %s +! RUN: bbc -emit-fir -gen-array-coor %s -o - | FileCheck %s --check-prefix=ArrayCoorCHECK + +! Test that non-contiguous assumed-shape memory layout is handled in lowering. +! In practice, test that input fir.box is propagated to fir operations + +! Also test that when the contiguous keyword is present, lowering adds the +! attribute to the fir argument and that is takes the contiguity into account +! In practice, test that the input fir.box is not propagated to fir operations. + +! CHECK-LABEL: func @_QPtest_element_ref(%arg0: !fir.box> {fir.bindc_name = "x", fir.contiguous}, %arg1: !fir.box>{{.*}}) { +! ArrayCoorCHECK-LABEL: func @_QPtest_element_ref +subroutine test_element_ref(x, y) + real, contiguous :: x(:) + ! CHECK-DAG: %[[xaddr:.*]] = fir.box_addr %arg0 : (!fir.box>) -> !fir.ref> + real :: y(4:) + ! CHECK-DAG: %[[c4:.*]] = fir.convert %c4{{.*}} : (i64) -> index + + call bar(x(100)) + ! CHECK: fir.coordinate_of %[[xaddr]], %{{.*}} : (!fir.ref>, i64) -> !fir.ref + call bar(y(100)) + ! Test that for an entity that is not know to be contiguous, the fir.box is passed + ! to coordinate of and that the lower bounds is already applied by lowering. + ! CHECK: %[[c4_2:.*]] = fir.convert %[[c4]] : (index) -> i64 + ! CHECK: %[[index:.*]] = arith.subi %c100{{.*}}, %[[c4_2]] : i64 + ! CHECK: fir.coordinate_of %arg1, %{{.*}} : (!fir.box>, i64) -> !fir.ref + + + ! Repeat test when lowering is using fir.array_coor + ! ArrayCoorCHECK-DAG: %[[xaddr:.*]] = fir.box_addr %arg0 : (!fir.box>) -> !fir.ref> + ! ArrayCoorCHECK-DAG: %[[xshape:.*]] = fir.shape + ! ArrayCoorCHECK-DAG: %[[c100:.*]] = fir.convert %c100{{.*}} : (i64) -> index + ! ArrayCoorCHECK: fir.array_coor %[[xaddr]](%[[xshape]]) %[[c100]] : (!fir.ref>, !fir.shapeshift<1>, index) -> !fir.ref + + ! ArrayCoorCHECK-DAG: %[[c100_1:.*]] = fir.convert %c100{{.*}} : (i64) -> index + ! ArrayCoorCHECK-DAG: %[[shift:.*]] = fir.shift %{{.*}} : (index) -> !fir.shift<1> + ! ArrayCoorCHECK: fir.array_coor %arg1(%[[shift]]) %[[c100_1]] : (!fir.box>, !fir.shift<1>, index) -> !fir.ref +end subroutine + +! CHECK-LABEL: func @_QPtest_element_assign(%arg0: !fir.box> {fir.bindc_name = "x", fir.contiguous}, %arg1: !fir.box>{{.*}}) { +! ArrayCoorCHECK-LABEL: func @_QPtest_element_assign +subroutine test_element_assign(x, y) + real, contiguous :: x(:) + ! CHECK-DAG: %[[xaddr:.*]] = fir.box_addr %arg0 : (!fir.box>) -> !fir.ref> + real :: y(4:) + ! CHECK-DAG: %[[c4:.*]] = fir.convert %c4{{.*}} : (i64) -> index + x(100) = 42. + ! CHECK: fir.coordinate_of %[[xaddr]], %{{.*}} : (!fir.ref>, i64) -> !fir.ref + y(100) = 42. + ! CHECK: %[[c4_2:.*]] = fir.convert %[[c4]] : (index) -> i64 + ! CHECK: %[[index:.*]] = arith.subi %c100{{.*}}, %[[c4_2]] : i64 + ! CHECK: fir.coordinate_of %arg1, %{{.*}} : (!fir.box>, i64) -> !fir.ref + + ! ArrayCoorCHECK-DAG: %[[xaddr:.*]] = fir.box_addr %arg0 : (!fir.box>) -> !fir.ref> + ! ArrayCoorCHECK-DAG: %[[xshape:.*]] = fir.shape + ! ArrayCoorCHECK-DAG: %[[c100:.*]] = fir.convert %c100{{.*}} : (i64) -> index + ! ArrayCoorCHECK: fir.array_coor %[[xaddr]](%[[xshape]]) %[[c100]] : (!fir.ref>, !fir.shapeshift<1>, index) -> !fir.ref + + ! ArrayCoorCHECK-DAG: %[[c100_1:.*]] = fir.convert %c100{{.*}} : (i64) -> index + ! ArrayCoorCHECK-DAG: %[[shift:.*]] = fir.shift %{{.*}} : (index) -> !fir.shift<1> + ! ArrayCoorCHECK: fir.array_coor %arg1(%[[shift]]) %[[c100_1]] : (!fir.box>, !fir.shift<1>, index) -> !fir.ref +end subroutine + +! CHECK-LABEL: func @_QPtest_ref_in_array_expr(%arg0: !fir.box> {fir.bindc_name = "x", fir.contiguous}, %arg1: !fir.box>{{.*}}) { +subroutine test_ref_in_array_expr(x, y) + real, contiguous :: x(:) + ! CHECK: %[[xaddr:.*]] = fir.box_addr %arg0 : (!fir.box>) -> !fir.ref> + real :: y(:) + call bar2(x+1.) + ! CHECK: fir.array_load %[[xaddr]](%{{.*}}) : (!fir.ref>, !fir.shapeshift<1>) -> !fir.array + call bar2(y+1.) + ! CHECK: fir.array_load %arg1 : (!fir.box>) -> !fir.array +end subroutine + + +! CHECK-LABEL: func @_QPtest_assign_in_array_ref(%arg0: !fir.box> {fir.bindc_name = "x", fir.contiguous}, %arg1: !fir.box>{{.*}}) { +subroutine test_assign_in_array_ref(x, y) + real, contiguous :: x(:) + ! CHECK: %[[xaddr:.*]] = fir.box_addr %arg0 : (!fir.box>) -> !fir.ref> + real :: y(:) + x = 42. + ! CHECK: %[[xload:.*]] = fir.array_load %[[xaddr]]({{.*}}) : (!fir.ref>, !fir.shapeshift<1>) -> !fir.array + ! CHECK: %[[xloop:.*]] = fir.do_loop {{.*}} iter_args(%arg3 = %[[xload]]) -> (!fir.array) + ! CHECK: fir.array_merge_store %[[xload]], %[[xloop]] to %[[xaddr]] : !fir.array, !fir.array, !fir.ref> + y = 42. + ! CHECK: %[[yload:.*]] = fir.array_load %arg1 : (!fir.box>) -> !fir.array + ! CHECK: %[[yloop:.*]] = fir.do_loop {{.*}} iter_args(%arg3 = %[[yload]]) -> (!fir.array) { + ! CHECK: fir.array_merge_store %[[yload]], %[[yloop]] to %arg1 : !fir.array, !fir.array, !fir.box> +end subroutine + +! CHECK-LABEL: func @_QPtest_slice_ref(%arg0: !fir.box> {fir.bindc_name = "x", fir.contiguous}, %arg1: !fir.box> +subroutine test_slice_ref(x, y, z1, z2, i, j, k, n) + real, contiguous :: x(:) + ! CHECK: %[[xaddr:.*]] = fir.box_addr %arg0 : (!fir.box>) -> !fir.ref> + real :: y(:) + integer :: i, j, k, n + real :: z1(n), z2(n) + z2 = x(i:j:k) + ! CHECK: %[[xslice:.*]] = fir.slice + ! CHECK: fir.array_load %[[xaddr]]{{.*}}%[[xslice]]{{.*}}: (!fir.ref>, !fir.shapeshift<1>, !fir.slice<1>) -> !fir.array + z1 = y(i:j:k) + ! CHECK: %[[yslice:.*]] = fir.slice + ! CHECK: fir.array_load %arg1 {{.*}}%[[yslice]]{{.*}} : (!fir.box>, !fir.slice<1>) -> !fir.array +end subroutine + +! CHECK-LABEL: func @_QPtest_slice_assign(%arg0: !fir.box> {fir.bindc_name = "x", fir.contiguous}, %arg1: !fir.box> +subroutine test_slice_assign(x, y, i, j, k) + real, contiguous :: x(:) + ! CHECK: %[[xaddr:.*]] = fir.box_addr %arg0 : (!fir.box>) -> !fir.ref> + real :: y(:) + integer :: i, j, k + x(i:j:k) = 42. + ! CHECK: %[[xslice:.*]] = fir.slice + ! CHECK: fir.array_load %[[xaddr]]{{.*}}%[[xslice]]{{.*}}: (!fir.ref>, !fir.shapeshift<1>, !fir.slice<1>) -> !fir.array + y(i:j:k) = 42. + ! CHECK: %[[yslice:.*]] = fir.slice + ! CHECK: fir.array_load %arg1 {{.*}}%[[yslice]]{{.*}}: (!fir.box>, !fir.slice<1>) -> !fir.array +end subroutine + +! test that allocatable are considered contiguous. +! CHECK-LABEL: func @_QPfoo +subroutine foo(x) + real, allocatable :: x(:) + call bar(x(100)) + ! CHECK: fir.coordinate_of %{{.*}}, %{{.*}} (!fir.heap>, i64) -> !fir.ref +end subroutine + +! Test that non-contiguous dummy are propagated with their memory layout (we +! mainly do not want to create a new box that would ignore the original layout). +! CHECK: func @_QPpropagate(%arg0: !fir.box> {fir.bindc_name = "x"}) +subroutine propagate(x) + interface + subroutine bar3(x) + real :: x(:) + end subroutine + end interface + real :: x(:) + call bar3(x) + ! CHECK: fir.call @_QPbar3(%arg0) : (!fir.box>) -> () +end subroutine diff --git a/flang/test/Lower/dummy-argument-optional-2.f90 b/flang/test/Lower/dummy-argument-optional-2.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Lower/dummy-argument-optional-2.f90 @@ -0,0 +1,427 @@ +! Test passing pointer, allocatables, and optional assumed shapes to optional +! explicit shapes (see F2018 15.5.2.12). +! RUN: bbc -emit-fir %s -o - | FileCheck %s +module optional_tests + implicit none + interface + subroutine takes_opt_scalar(i) + integer, optional :: i + end subroutine + subroutine takes_opt_scalar_char(c) + character(*), optional :: c + end subroutine + subroutine takes_opt_explicit_shape(x) + real, optional :: x(100) + end subroutine + subroutine takes_opt_explicit_shape_intentout(x) + real, optional, intent(out) :: x(100) + end subroutine + subroutine takes_opt_explicit_shape_intentin(x) + real, optional, intent(in) :: x(100) + end subroutine + subroutine takes_opt_explicit_shape_char(c) + character(*), optional :: c(100) + end subroutine + function returns_pointer() + real, pointer :: returns_pointer(:) + end function + end interface + contains + + ! ----------------------------------------------------------------------------- + ! Test passing scalar pointers and allocatables to an optional + ! ----------------------------------------------------------------------------- + ! Here, nothing optional specific is expected, the address is passed, and its + ! allocation/association status match the dummy presence status. + + ! CHECK-LABEL: func @_QMoptional_testsPpass_pointer_scalar( + ! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref>>{{.*}}) { + subroutine pass_pointer_scalar(i) + integer, pointer :: i + call takes_opt_scalar(i) + ! CHECK: %[[VAL_1:.*]] = fir.load %[[VAL_0]] : !fir.ref>> + ! CHECK: %[[VAL_2:.*]] = fir.box_addr %[[VAL_1]] : (!fir.box>) -> !fir.ptr + ! CHECK: %[[VAL_3:.*]] = fir.convert %[[VAL_2]] : (!fir.ptr) -> !fir.ref + ! CHECK: fir.call @_QPtakes_opt_scalar(%[[VAL_3]]) : (!fir.ref) -> () + end subroutine + + ! CHECK-LABEL: func @_QMoptional_testsPpass_allocatable_scalar( + ! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref>>{{.*}}) { + subroutine pass_allocatable_scalar(i) + integer, allocatable :: i + call takes_opt_scalar(i) + ! CHECK: %[[VAL_1:.*]] = fir.load %[[VAL_0]] : !fir.ref>> + ! CHECK: %[[VAL_2:.*]] = fir.box_addr %[[VAL_1]] : (!fir.box>) -> !fir.heap + ! CHECK: %[[VAL_3:.*]] = fir.convert %[[VAL_2]] : (!fir.heap) -> !fir.ref + ! CHECK: fir.call @_QPtakes_opt_scalar(%[[VAL_3]]) : (!fir.ref) -> () + end subroutine + + ! CHECK-LABEL: func @_QMoptional_testsPpass_pointer_scalar_char( + ! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref>>>{{.*}}) { + subroutine pass_pointer_scalar_char(c) + character(:), pointer :: c + call takes_opt_scalar_char(c) + ! CHECK: %[[VAL_1:.*]] = fir.load %[[VAL_0]] : !fir.ref>>> + ! CHECK: %[[VAL_2:.*]] = fir.box_elesize %[[VAL_1]] : (!fir.box>>) -> index + ! CHECK: %[[VAL_3:.*]] = fir.box_addr %[[VAL_1]] : (!fir.box>>) -> !fir.ptr> + ! CHECK: %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (!fir.ptr>) -> !fir.ref> + ! CHECK: %[[VAL_5:.*]] = fir.emboxchar %[[VAL_4]], %[[VAL_2]] : (!fir.ref>, index) -> !fir.boxchar<1> + ! CHECK: fir.call @_QPtakes_opt_scalar_char(%[[VAL_5]]) : (!fir.boxchar<1>) -> () + end subroutine + + ! CHECK-LABEL: func @_QMoptional_testsPpass_allocatable_scalar_char( + ! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref>>>{{.*}}) { + subroutine pass_allocatable_scalar_char(c) + character(:), allocatable :: c + call takes_opt_scalar_char(c) + ! CHECK: %[[VAL_1:.*]] = fir.load %[[VAL_0]] : !fir.ref>>> + ! CHECK: %[[VAL_2:.*]] = fir.box_elesize %[[VAL_1]] : (!fir.box>>) -> index + ! CHECK: %[[VAL_3:.*]] = fir.box_addr %[[VAL_1]] : (!fir.box>>) -> !fir.heap> + ! CHECK: %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (!fir.heap>) -> !fir.ref> + ! CHECK: %[[VAL_5:.*]] = fir.emboxchar %[[VAL_4]], %[[VAL_2]] : (!fir.ref>, index) -> !fir.boxchar<1> + ! CHECK: fir.call @_QPtakes_opt_scalar_char(%[[VAL_5]]) : (!fir.boxchar<1>) -> () + end subroutine + + ! ----------------------------------------------------------------------------- + ! Test passing non contiguous pointers to explicit shape optional + ! ----------------------------------------------------------------------------- + ! The pointer descriptor can be unconditionally read, but the copy-in/copy-out + ! must be conditional on the pointer association status in order to get the + ! correct present/absent aspect. + + ! CHECK-LABEL: func @_QMoptional_testsPpass_pointer_array( + ! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref>>>{{.*}}) { + subroutine pass_pointer_array(i) + real, pointer :: i(:) + call takes_opt_explicit_shape(i) + ! CHECK: %[[VAL_1:.*]] = fir.load %[[VAL_0]] : !fir.ref>>> + ! CHECK: %[[VAL_2:.*]] = fir.box_addr %[[VAL_1]] : (!fir.box>>) -> !fir.ptr> + ! CHECK: %[[VAL_3:.*]] = fir.convert %[[VAL_2]] : (!fir.ptr>) -> i64 + ! CHECK: %[[VAL_4:.*]] = arith.constant 0 : i64 + ! CHECK: %[[VAL_5:.*]] = arith.cmpi ne, %[[VAL_3]], %[[VAL_4]] : i64 + ! CHECK: %[[VAL_6:.*]] = fir.load %[[VAL_0]] : !fir.ref>>> + ! CHECK: %[[VAL_7:.*]] = arith.constant 0 : index + ! CHECK: %[[VAL_9:.*]] = fir.if %[[VAL_5]] -> (!fir.heap>) { + ! CHECK: %[[VAL_10:.*]] = arith.constant 0 : index + ! CHECK: %[[VAL_11:.*]]:3 = fir.box_dims %[[VAL_6]], %[[VAL_10]] : (!fir.box>>, index) -> (index, index, index) + ! CHECK: %[[VAL_12:.*]] = fir.allocmem !fir.array, %[[VAL_11]]#1 {uniq_name = ".copyinout"} + ! CHECK: %[[VAL_20:.*]] = fir.do_loop {{.*}} { + ! CHECK: } + ! CHECK: fir.array_merge_store %{{.*}}, %[[VAL_20]] to %[[VAL_12]] : !fir.array, !fir.array, !fir.heap> + ! CHECK: fir.result %[[VAL_12]] : !fir.heap> + ! CHECK: } else { + ! CHECK: %[[VAL_26:.*]] = fir.zero_bits !fir.heap> + ! CHECK: fir.result %[[VAL_26]] : !fir.heap> + ! CHECK: } + ! CHECK: %[[VAL_29:.*]] = fir.convert %[[VAL_9]] : (!fir.heap>) -> !fir.ref> + ! CHECK: fir.call @_QPtakes_opt_explicit_shape(%[[VAL_29]]) : (!fir.ref>) -> () + ! CHECK: fir.if %[[VAL_5]] { + ! CHECK: %[[VAL_40:.*]] = fir.do_loop {{.*}} { + ! CHECK: } + ! CHECK: fir.array_merge_store %{{.*}}, %[[VAL_40]] to %[[VAL_6]] : !fir.array, !fir.array, !fir.box>> + ! CHECK: fir.freemem %[[VAL_9]] + ! CHECK: } + end subroutine + + ! CHECK-LABEL: func @_QMoptional_testsPpass_pointer_array_char( + ! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref>>>>{{.*}}) { + subroutine pass_pointer_array_char(c) + character(:), pointer :: c(:) + call takes_opt_explicit_shape_char(c) + ! CHECK: %[[VAL_1:.*]] = fir.load %[[VAL_0]] : !fir.ref>>>> + ! CHECK: %[[VAL_2:.*]] = fir.box_addr %[[VAL_1]] : (!fir.box>>>) -> !fir.ptr>> + ! CHECK: %[[VAL_3:.*]] = fir.convert %[[VAL_2]] : (!fir.ptr>>) -> i64 + ! CHECK: %[[VAL_4:.*]] = arith.constant 0 : i64 + ! CHECK: %[[VAL_5:.*]] = arith.cmpi ne, %[[VAL_3]], %[[VAL_4]] : i64 + ! CHECK: %[[VAL_6:.*]] = fir.load %[[VAL_0]] : !fir.ref>>>> + ! CHECK: %[[VAL_9:.*]] = fir.if %[[VAL_5]] -> (!fir.heap>>) { + ! CHECK: %[[VAL_10:.*]] = arith.constant 0 : index + ! CHECK: %[[VAL_11:.*]]:3 = fir.box_dims %[[VAL_6]], %[[VAL_10]] : (!fir.box>>>, index) -> (index, index, index) + ! CHECK: %[[VAL_12:.*]] = fir.box_elesize %[[VAL_6]] : (!fir.box>>>) -> index + ! CHECK: %[[VAL_13:.*]] = fir.allocmem !fir.array>(%[[VAL_12]] : index), %[[VAL_11]]#1 {uniq_name = ".copyinout"} + ! CHECK: %[[VAL_21:.*]] = fir.do_loop {{.*}} { + ! CHECK: } + ! CHECK: fir.array_merge_store %{{.*}}, %[[VAL_21]] to %[[VAL_13]] typeparams %[[VAL_12]] : !fir.array>, !fir.array>, !fir.heap>>, index + ! CHECK: fir.result %[[VAL_13]] : !fir.heap>> + ! CHECK: } else { + ! CHECK: %[[VAL_46:.*]] = fir.zero_bits !fir.heap>> + ! CHECK: fir.result %[[VAL_46]] : !fir.heap>> + ! CHECK: } + ! CHECK: %[[VAL_47:.*]] = fir.box_elesize %[[VAL_6]] : (!fir.box>>>) -> index + ! CHECK: %[[VAL_50:.*]] = fir.convert %[[VAL_9]] : (!fir.heap>>) -> !fir.ref> + ! CHECK: %[[VAL_52:.*]] = fir.emboxchar %[[VAL_50]], %[[VAL_47]] : (!fir.ref>, index) -> !fir.boxchar<1> + ! CHECK: fir.call @_QPtakes_opt_explicit_shape_char(%[[VAL_52]]) : (!fir.boxchar<1>) -> () + ! CHECK: fir.if %[[VAL_5]] { + ! CHECK: %[[VAL_62:.*]] = fir.do_loop {{.*}} { + ! CHECK: } + ! CHECK: fir.array_merge_store %{{.*}}, %[[VAL_62]] to %[[VAL_6]] : !fir.array>, !fir.array>, !fir.box>>> + ! CHECK: fir.freemem %[[VAL_9]] + ! CHECK: } + ! CHECK: return + ! CHECK: } + end subroutine + + ! This case is bit special because the pointer is not a symbol but a function + ! result. Test that the copy-in/copy-out is the same as with normal pointers. + + ! CHECK-LABEL: func @_QMoptional_testsPforward_pointer_array() { + subroutine forward_pointer_array() + call takes_opt_explicit_shape(returns_pointer()) + ! CHECK: %[[VAL_0:.*]] = fir.alloca !fir.box>> {bindc_name = ".result"} + ! CHECK: %[[VAL_1:.*]] = fir.call @_QPreturns_pointer() : () -> !fir.box>> + ! CHECK: fir.save_result %[[VAL_1]] to %[[VAL_0]] : !fir.box>>, !fir.ref>>> + ! CHECK: %[[VAL_2:.*]] = fir.load %[[VAL_0]] : !fir.ref>>> + ! CHECK: %[[VAL_3:.*]] = fir.box_addr %[[VAL_2]] : (!fir.box>>) -> !fir.ptr> + ! CHECK: %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (!fir.ptr>) -> i64 + ! CHECK: %[[VAL_5:.*]] = arith.constant 0 : i64 + ! CHECK: %[[VAL_6:.*]] = arith.cmpi ne, %[[VAL_4]], %[[VAL_5]] : i64 + ! CHECK: %[[VAL_7:.*]] = fir.if %[[VAL_6]] -> (!fir.heap>) { + ! CHECK: %[[VAL_10:.*]] = fir.allocmem !fir.array + ! CHECK: fir.do_loop {{.*}} { + ! CHECK: } + ! CHECK: fir.result %[[VAL_10]] : !fir.heap> + ! CHECK: } else { + ! CHECK: %[[VAL_11:.*]] = fir.zero_bits !fir.heap> + ! CHECK: fir.result %[[VAL_11]] : !fir.heap> + ! CHECK: } + ! CHECK: %[[VAL_14:.*]] = fir.convert %[[VAL_7]] : (!fir.heap>) -> !fir.ref> + ! CHECK: fir.call @_QPtakes_opt_explicit_shape(%[[VAL_14]]) : (!fir.ref>) -> () + ! CHECK: fir.if %[[VAL_6]] { + ! CHECK: fir.do_loop {{.*}} { + ! CHECK: } + ! CHECK: fir.freemem %[[VAL_7]] + ! CHECK: } + end subroutine + + ! ----------------------------------------------------------------------------- + ! Test passing assumed shape optional to explicit shape optional + ! ----------------------------------------------------------------------------- + ! The fix.box can only be read if the assumed shape is present, + ! and the copy-in/copy-out must also be conditional on the assumed + ! shape presence. + + ! CHECK-LABEL: func @_QMoptional_testsPpass_opt_assumed_shape( + ! CHECK-SAME: %[[VAL_0:.*]]: !fir.box> {fir.bindc_name = "x", fir.optional}) { + subroutine pass_opt_assumed_shape(x) + real, optional :: x(:) + call takes_opt_explicit_shape(x) + ! CHECK: %[[VAL_1:.*]] = fir.is_present %[[VAL_0]] : (!fir.box>) -> i1 + ! CHECK: %[[VAL_2:.*]] = fir.zero_bits !fir.ref> + ! CHECK: %[[VAL_3:.*]] = arith.constant 0 : index + ! CHECK: %[[VAL_4:.*]] = fir.shape %[[VAL_3]] : (index) -> !fir.shape<1> + ! CHECK: %[[VAL_5:.*]] = fir.embox %[[VAL_2]](%[[VAL_4]]) : (!fir.ref>, !fir.shape<1>) -> !fir.box> + ! CHECK: %[[VAL_6:.*]] = arith.select %[[VAL_1]], %[[VAL_0]], %[[VAL_5]] : !fir.box> + ! CHECK: %[[VAL_7:.*]] = fir.if %[[VAL_1]] -> (!fir.heap>) { + ! CHECK: %[[VAL_8:.*]] = arith.constant 0 : index + ! CHECK: %[[VAL_9:.*]]:3 = fir.box_dims %[[VAL_6]], %[[VAL_8]] : (!fir.box>, index) -> (index, index, index) + ! CHECK: %[[VAL_10:.*]] = fir.allocmem !fir.array, %[[VAL_9]]#1 {uniq_name = ".copyinout"} + ! CHECK: %[[VAL_17:.*]] = fir.do_loop {{.*}} { + ! CHECK: } + ! CHECK: fir.array_merge_store %{{.*}}, %[[VAL_17]] to %[[VAL_10]] : !fir.array, !fir.array, !fir.heap> + ! CHECK: fir.result %[[VAL_10]] : !fir.heap> + ! CHECK: } else { + ! CHECK: %[[VAL_23:.*]] = fir.zero_bits !fir.heap> + ! CHECK: fir.result %[[VAL_23]] : !fir.heap> + ! CHECK: } + ! CHECK: %[[VAL_26:.*]] = fir.convert %[[VAL_27:.*]] : (!fir.heap>) -> !fir.ref> + ! CHECK: fir.call @_QPtakes_opt_explicit_shape(%[[VAL_26]]) : (!fir.ref>) -> () + ! CHECK: fir.if %[[VAL_1]] { + ! CHECK: %[[VAL_36:.*]] = fir.do_loop {{.*}} { + ! CHECK: } + ! CHECK: fir.array_merge_store %{{.*}}, %[[VAL_36]] to %[[VAL_6]] : !fir.array, !fir.array, !fir.box> + ! CHECK: fir.freemem %[[VAL_27]] + ! CHECK: } + end subroutine + + ! CHECK-LABEL: func @_QMoptional_testsPpass_opt_assumed_shape_char( + ! CHECK-SAME: %[[VAL_0:.*]]: !fir.box>> {fir.bindc_name = "c", fir.optional}) { + subroutine pass_opt_assumed_shape_char(c) + character(*), optional :: c(:) + call takes_opt_explicit_shape_char(c) + ! CHECK: %[[VAL_1:.*]] = fir.is_present %[[VAL_0]] : (!fir.box>>) -> i1 + ! CHECK: %[[VAL_2:.*]] = fir.zero_bits !fir.ref>> + ! CHECK: %[[VAL_3:.*]] = arith.constant 0 : index + ! CHECK: %[[VAL_4:.*]] = fir.shape %[[VAL_3]] : (index) -> !fir.shape<1> + ! CHECK: %[[VAL_5:.*]] = arith.constant 0 : index + ! CHECK: %[[VAL_6:.*]] = fir.embox %[[VAL_2]](%[[VAL_4]]) typeparams %[[VAL_5]] : (!fir.ref>>, !fir.shape<1>, index) -> !fir.box>> + ! CHECK: %[[VAL_7:.*]] = arith.select %[[VAL_1]], %[[VAL_0]], %[[VAL_6]] : !fir.box>> + ! CHECK: %[[VAL_8:.*]] = fir.if %[[VAL_1]] -> (!fir.heap>>) { + ! CHECK: %[[VAL_19:.*]] = fir.do_loop {{.*}} { + ! CHECK: } + ! CHECK: fir.array_merge_store %{{.*}}, %[[VAL_19]] to %[[VAL_12]] typeparams %[[VAL_11]] : !fir.array>, !fir.array>, !fir.heap>>, index + ! CHECK: fir.result %[[VAL_12]] : !fir.heap>> + ! CHECK: } else { + ! CHECK: %[[VAL_44:.*]] = fir.zero_bits !fir.heap>> + ! CHECK: fir.result %[[VAL_44]] : !fir.heap>> + ! CHECK: } + ! CHECK: %[[VAL_45:.*]] = fir.box_elesize %[[VAL_7]] : (!fir.box>>) -> index + ! CHECK: %[[VAL_48:.*]] = fir.convert %[[VAL_49:.*]] : (!fir.heap>>) -> !fir.ref> + ! CHECK: %[[VAL_50:.*]] = fir.emboxchar %[[VAL_48]], %[[VAL_45]] : (!fir.ref>, index) -> !fir.boxchar<1> + ! CHECK: fir.call @_QPtakes_opt_explicit_shape_char(%[[VAL_50]]) : (!fir.boxchar<1>) -> () + ! CHECK: fir.if %[[VAL_1]] { + ! CHECK: %[[VAL_59:.*]] = fir.do_loop {{.*}} { + ! CHECK: fir.array_merge_store %{{.*}}, %[[VAL_59]] to %[[VAL_7]] : !fir.array>, !fir.array>, !fir.box>> + ! CHECK: fir.freemem %[[VAL_49]] + ! CHECK: } + end subroutine + + ! ----------------------------------------------------------------------------- + ! Test passing contiguous optional assumed shape to explicit shape optional + ! ----------------------------------------------------------------------------- + ! The fix.box can only be read if the assumed shape is present. + ! There should be no copy-in/copy-out + + ! CHECK-LABEL: func @_QMoptional_testsPpass_opt_contiguous_assumed_shape( + ! CHECK-SAME: %[[VAL_0:.*]]: !fir.box> {fir.bindc_name = "x", fir.contiguous, fir.optional}) { + subroutine pass_opt_contiguous_assumed_shape(x) + real, optional, contiguous :: x(:) + call takes_opt_explicit_shape(x) + ! CHECK: %[[VAL_1:.*]] = fir.is_present %[[VAL_0]] : (!fir.box>) -> i1 + ! CHECK: %[[VAL_2:.*]] = fir.zero_bits !fir.ref> + ! CHECK: %[[VAL_3:.*]] = arith.constant 0 : index + ! CHECK: %[[VAL_4:.*]] = fir.shape %[[VAL_3]] : (index) -> !fir.shape<1> + ! CHECK: %[[VAL_5:.*]] = fir.embox %[[VAL_2]](%[[VAL_4]]) : (!fir.ref>, !fir.shape<1>) -> !fir.box> + ! CHECK: %[[VAL_6:.*]] = arith.select %[[VAL_1]], %[[VAL_0]], %[[VAL_5]] : !fir.box> + ! CHECK: %[[VAL_7:.*]] = fir.box_addr %[[VAL_6]] : (!fir.box>) -> !fir.ref> + ! CHECK: %[[VAL_8:.*]] = fir.convert %[[VAL_7]] : (!fir.ref>) -> !fir.ref> + ! CHECK: fir.call @_QPtakes_opt_explicit_shape(%[[VAL_8]]) : (!fir.ref>) -> () + end subroutine + + ! CHECK-LABEL: func @_QMoptional_testsPpass_opt_contiguous_assumed_shape_char( + ! CHECK-SAME: %[[VAL_0:.*]]: !fir.box>> {fir.bindc_name = "c", fir.contiguous, fir.optional}) { + subroutine pass_opt_contiguous_assumed_shape_char(c) + character(*), optional, contiguous :: c(:) + call takes_opt_explicit_shape_char(c) + ! CHECK: %[[VAL_1:.*]] = fir.is_present %[[VAL_0]] : (!fir.box>>) -> i1 + ! CHECK: %[[VAL_2:.*]] = fir.zero_bits !fir.ref>> + ! CHECK: %[[VAL_3:.*]] = arith.constant 0 : index + ! CHECK: %[[VAL_4:.*]] = fir.shape %[[VAL_3]] : (index) -> !fir.shape<1> + ! CHECK: %[[VAL_5:.*]] = arith.constant 0 : index + ! CHECK: %[[VAL_6:.*]] = fir.embox %[[VAL_2]](%[[VAL_4]]) typeparams %[[VAL_5]] : (!fir.ref>>, !fir.shape<1>, index) -> !fir.box>> + ! CHECK: %[[VAL_7:.*]] = arith.select %[[VAL_1]], %[[VAL_0]], %[[VAL_6]] : !fir.box>> + ! CHECK: %[[VAL_8:.*]] = fir.box_addr %[[VAL_7]] : (!fir.box>>) -> !fir.ref>> + ! CHECK: %[[VAL_9:.*]] = fir.box_elesize %[[VAL_7]] : (!fir.box>>) -> index + ! CHECK: %[[VAL_10:.*]] = fir.convert %[[VAL_8]] : (!fir.ref>>) -> !fir.ref> + ! CHECK: %[[VAL_11:.*]] = fir.emboxchar %[[VAL_10]], %[[VAL_9]] : (!fir.ref>, index) -> !fir.boxchar<1> + ! CHECK: fir.call @_QPtakes_opt_explicit_shape_char(%[[VAL_11]]) : (!fir.boxchar<1>) -> () + end subroutine + + ! ----------------------------------------------------------------------------- + ! Test passing allocatables and contiguous pointers to explicit shape optional + ! ----------------------------------------------------------------------------- + ! The fix.box can be read and its address directly passed. There should be no + ! copy-in/copy-out. + + ! CHECK-LABEL: func @_QMoptional_testsPpass_allocatable_array( + ! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref>>>{{.*}}) { + subroutine pass_allocatable_array(i) + real, allocatable :: i(:) + call takes_opt_explicit_shape(i) + ! CHECK: %[[VAL_1:.*]] = fir.load %[[VAL_0]] : !fir.ref>>> + ! CHECK: %[[VAL_2:.*]] = fir.box_addr %[[VAL_1]] : (!fir.box>>) -> !fir.heap> + ! CHECK: %[[VAL_3:.*]] = fir.convert %[[VAL_2]] : (!fir.heap>) -> !fir.ref> + ! CHECK: fir.call @_QPtakes_opt_explicit_shape(%[[VAL_3]]) : (!fir.ref>) -> () + end subroutine + + ! CHECK-LABEL: func @_QMoptional_testsPpass_allocatable_array_char( + ! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref>>>>{{.*}}) { + subroutine pass_allocatable_array_char(c) + character(:), allocatable :: c(:) + call takes_opt_explicit_shape_char(c) + ! CHECK: %[[VAL_1:.*]] = fir.load %[[VAL_0]] : !fir.ref>>>> + ! CHECK: %[[VAL_2:.*]] = fir.box_elesize %[[VAL_1]] : (!fir.box>>>) -> index + ! CHECK: %[[VAL_3:.*]] = fir.box_addr %[[VAL_1]] : (!fir.box>>>) -> !fir.heap>> + ! CHECK: %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (!fir.heap>>) -> !fir.ref> + ! CHECK: %[[VAL_5:.*]] = fir.emboxchar %[[VAL_4]], %[[VAL_2]] : (!fir.ref>, index) -> !fir.boxchar<1> + ! CHECK: fir.call @_QPtakes_opt_explicit_shape_char(%[[VAL_5]]) : (!fir.boxchar<1>) -> () + end subroutine + + ! CHECK-LABEL: func @_QMoptional_testsPpass_contiguous_pointer_array( + ! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref>>> {fir.bindc_name = "i", fir.contiguous}) { + subroutine pass_contiguous_pointer_array(i) + real, pointer, contiguous :: i(:) + call takes_opt_explicit_shape(i) + ! CHECK: %[[VAL_1:.*]] = fir.load %[[VAL_0]] : !fir.ref>>> + ! CHECK: %[[VAL_2:.*]] = fir.box_addr %[[VAL_1]] : (!fir.box>>) -> !fir.ptr> + ! CHECK: %[[VAL_3:.*]] = fir.convert %[[VAL_2]] : (!fir.ptr>) -> !fir.ref> + ! CHECK: fir.call @_QPtakes_opt_explicit_shape(%[[VAL_3]]) : (!fir.ref>) -> () + end subroutine + + ! CHECK-LABEL: func @_QMoptional_testsPpass_contiguous_pointer_array_char( + ! CHECK-SAME: %[[VAL_0:.*]]: !fir.ref>>>> {fir.bindc_name = "c", fir.contiguous}) { + subroutine pass_contiguous_pointer_array_char(c) + character(:), pointer, contiguous :: c(:) + call takes_opt_explicit_shape_char(c) + ! CHECK: %[[VAL_1:.*]] = fir.load %[[VAL_0]] : !fir.ref>>>> + ! CHECK: %[[VAL_2:.*]] = fir.box_elesize %[[VAL_1]] : (!fir.box>>>) -> index + ! CHECK: %[[VAL_3:.*]] = fir.box_addr %[[VAL_1]] : (!fir.box>>>) -> !fir.ptr>> + ! CHECK: %[[VAL_4:.*]] = fir.convert %[[VAL_3]] : (!fir.ptr>>) -> !fir.ref> + ! CHECK: %[[VAL_5:.*]] = fir.emboxchar %[[VAL_4]], %[[VAL_2]] : (!fir.ref>, index) -> !fir.boxchar<1> + ! CHECK: fir.call @_QPtakes_opt_explicit_shape_char(%[[VAL_5]]) : (!fir.boxchar<1>) -> () + end subroutine + + ! ----------------------------------------------------------------------------- + ! Test passing assumed shape optional to explicit shape optional with intents + ! ----------------------------------------------------------------------------- + ! The fix.box can only be read if the assumed shape is present, + ! and the copy-in/copy-out must also be conditional on the assumed + ! shape presence. For intent(in), there should be no copy-out while for + ! intent(out), there should be no copy-in. + + ! CHECK-LABEL: func @_QMoptional_testsPpass_opt_assumed_shape_to_intentin( + ! CHECK-SAME: %[[VAL_0:.*]]: !fir.box> {fir.bindc_name = "x", fir.optional}) { + subroutine pass_opt_assumed_shape_to_intentin(x) + real, optional :: x(:) + call takes_opt_explicit_shape_intentin(x) + ! CHECK: %[[VAL_1:.*]] = fir.is_present %[[VAL_0]] : (!fir.box>) -> i1 + ! CHECK: %[[VAL_2:.*]] = fir.zero_bits !fir.ref> + ! CHECK: %[[VAL_3:.*]] = arith.constant 0 : index + ! CHECK: %[[VAL_4:.*]] = fir.shape %[[VAL_3]] : (index) -> !fir.shape<1> + ! CHECK: %[[VAL_5:.*]] = fir.embox %[[VAL_2]](%[[VAL_4]]) : (!fir.ref>, !fir.shape<1>) -> !fir.box> + ! CHECK: %[[VAL_6:.*]] = arith.select %[[VAL_1]], %[[VAL_0]], %[[VAL_5]] : !fir.box> + ! CHECK: %[[VAL_7:.*]] = fir.if %[[VAL_1]] -> (!fir.heap>) { + ! CHECK: %[[VAL_10:.*]] = fir.allocmem !fir.array + ! CHECK: fir.do_loop {{.*}} { + ! CHECK: } + ! CHECK: fir.result %[[VAL_10]] : !fir.heap> + ! CHECK: } else { + ! CHECK: %[[VAL_23:.*]] = fir.zero_bits !fir.heap> + ! CHECK: fir.result %[[VAL_23]] : !fir.heap> + ! CHECK: } + ! CHECK: %[[VAL_24:.*]] = fir.convert %[[VAL_7]] : (!fir.heap>) -> !fir.ref> + ! CHECK: fir.call @_QPtakes_opt_explicit_shape_intentin(%[[VAL_24]]) : (!fir.ref>) -> () + ! CHECK: fir.if %[[VAL_1]] { + ! CHECK-NOT: fir.do_loop + ! CHECK: fir.freemem %[[VAL_7]] + ! CHECK: } + end subroutine + + ! CHECK-LABEL: func @_QMoptional_testsPpass_opt_assumed_shape_to_intentout( + ! CHECK-SAME: %[[VAL_0:.*]]: !fir.box> {fir.bindc_name = "x", fir.optional}) { + subroutine pass_opt_assumed_shape_to_intentout(x) + real, optional :: x(:) + call takes_opt_explicit_shape_intentout(x) + ! CHECK: %[[VAL_1:.*]] = fir.is_present %[[VAL_0]] : (!fir.box>) -> i1 + ! CHECK: %[[VAL_2:.*]] = fir.zero_bits !fir.ref> + ! CHECK: %[[VAL_3:.*]] = arith.constant 0 : index + ! CHECK: %[[VAL_4:.*]] = fir.shape %[[VAL_3]] : (index) -> !fir.shape<1> + ! CHECK: %[[VAL_5:.*]] = fir.embox %[[VAL_2]](%[[VAL_4]]) : (!fir.ref>, !fir.shape<1>) -> !fir.box> + ! CHECK: %[[VAL_6:.*]] = arith.select %[[VAL_1]], %[[VAL_0]], %[[VAL_5]] : !fir.box> + ! CHECK: %[[VAL_7:.*]] = fir.if %[[VAL_1]] -> (!fir.heap>) { + ! CHECK: %[[VAL_10:.*]] = fir.allocmem !fir.array + ! CHECK-NOT: fir.do_loop + ! CHECK: fir.result %[[VAL_10]] : !fir.heap> + ! CHECK: } else { + ! CHECK: %[[VAL_11:.*]] = fir.zero_bits !fir.heap> + ! CHECK: fir.result %[[VAL_11]] : !fir.heap> + ! CHECK: } + ! CHECK: %[[VAL_14:.*]] = fir.convert %[[VAL_7]] : (!fir.heap>) -> !fir.ref> + ! CHECK: fir.call @_QPtakes_opt_explicit_shape_intentout(%[[VAL_14]]) : (!fir.ref>) -> () + ! CHECK: fir.if %[[VAL_1]] { + ! CHECK: fir.do_loop {{.*}} { + ! CHECK: } + ! CHECK: fir.freemem %[[VAL_7]] + ! CHECK: } + end subroutine + end module + \ No newline at end of file diff --git a/flang/test/Lower/dummy-argument-optional.f90 b/flang/test/Lower/dummy-argument-optional.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Lower/dummy-argument-optional.f90 @@ -0,0 +1,157 @@ +! RUN: bbc -emit-fir %s -o - | FileCheck %s + +! Test OPTIONAL lowering on caller/callee and PRESENT intrinsic. +module opt + implicit none + type t + real, allocatable :: p(:) + end type +contains + +! Test simple scalar optional +! CHECK-LABEL: func @_QMoptPintrinsic_scalar( +! CHECK-SAME: %[[arg0:.*]]: !fir.ref {fir.bindc_name = "x", fir.optional}) { +subroutine intrinsic_scalar(x) + real, optional :: x + ! CHECK: fir.is_present %[[arg0]] : (!fir.ref) -> i1 + print *, present(x) +end subroutine +! CHECK-LABEL: @_QMoptPcall_intrinsic_scalar() +subroutine call_intrinsic_scalar() + ! CHECK: %[[x:.*]] = fir.alloca f32 + real :: x + ! CHECK: fir.call @_QMoptPintrinsic_scalar(%[[x]]) : (!fir.ref) -> () + call intrinsic_scalar(x) + ! CHECK: %[[absent:.*]] = fir.absent !fir.ref + ! CHECK: fir.call @_QMoptPintrinsic_scalar(%[[absent]]) : (!fir.ref) -> () + call intrinsic_scalar() +end subroutine + +! Test explicit shape array optional +! CHECK-LABEL: func @_QMoptPintrinsic_f77_array( +! CHECK-SAME: %[[arg0:.*]]: !fir.ref> {fir.bindc_name = "x", fir.optional}) { +subroutine intrinsic_f77_array(x) + real, optional :: x(100) + ! CHECK: fir.is_present %[[arg0]] : (!fir.ref>) -> i1 + print *, present(x) +end subroutine +! CHECK-LABEL: func @_QMoptPcall_intrinsic_f77_array() +subroutine call_intrinsic_f77_array() + ! CHECK: %[[x:.*]] = fir.alloca !fir.array<100xf32> + real :: x(100) + ! CHECK: fir.call @_QMoptPintrinsic_f77_array(%[[x]]) : (!fir.ref>) -> () + call intrinsic_f77_array(x) + ! CHECK: %[[absent:.*]] = fir.absent !fir.ref> + ! CHECK: fir.call @_QMoptPintrinsic_f77_array(%[[absent]]) : (!fir.ref>) -> () + call intrinsic_f77_array() +end subroutine + +! Test optional character scalar +! CHECK-LABEL: func @_QMoptPcharacter_scalar( +! CHECK-SAME: %[[arg0:.*]]: !fir.boxchar<1> {fir.bindc_name = "x", fir.optional}) { +subroutine character_scalar(x) + ! CHECK: %[[unboxed:.*]]:2 = fir.unboxchar %[[arg0]] : (!fir.boxchar<1>) -> (!fir.ref>, index) + character(10), optional :: x + ! CHECK: fir.is_present %[[unboxed]]#0 : (!fir.ref>) -> i1 + print *, present(x) +end subroutine +! CHECK-LABEL: func @_QMoptPcall_character_scalar() +subroutine call_character_scalar() + ! CHECK: %[[addr:.*]] = fir.alloca !fir.char<1,10> + character(10) :: x + ! CHECK: %[[addrCast:.*]] = fir.convert %[[addr]] + ! CHECK: %[[x:.*]] = fir.emboxchar %[[addrCast]], {{.*}} + ! CHECK: fir.call @_QMoptPcharacter_scalar(%[[x]]) : (!fir.boxchar<1>) -> () + call character_scalar(x) + ! CHECK: %[[absent:.*]] = fir.absent !fir.boxchar<1> + ! CHECK: fir.call @_QMoptPcharacter_scalar(%[[absent]]) : (!fir.boxchar<1>) -> () + call character_scalar() +end subroutine + +! Test optional assumed shape +! CHECK-LABEL: func @_QMoptPassumed_shape( +! CHECK-SAME: %[[arg0:.*]]: !fir.box> {fir.bindc_name = "x", fir.optional}) { +subroutine assumed_shape(x) + real, optional :: x(:) + ! CHECK: fir.is_present %[[arg0]] : (!fir.box>) -> i1 + print *, present(x) +end subroutine +! CHECK: func @_QMoptPcall_assumed_shape() +subroutine call_assumed_shape() + ! CHECK: %[[addr:.*]] = fir.alloca !fir.array<100xf32> + real :: x(100) + ! CHECK: %[[embox:.*]] = fir.embox %[[addr]] + ! CHECK: %[[x:.*]] = fir.convert %[[embox]] : (!fir.box>) -> !fir.box> + ! CHECK: fir.call @_QMoptPassumed_shape(%[[x]]) : (!fir.box>) -> () + call assumed_shape(x) + ! CHECK: %[[absent:.*]] = fir.absent !fir.box> + ! CHECK: fir.call @_QMoptPassumed_shape(%[[absent]]) : (!fir.box>) -> () + call assumed_shape() +end subroutine + +! Test optional allocatable +! CHECK: func @_QMoptPallocatable_array( +! CHECK-SAME: %[[arg0:.*]]: !fir.ref>>> {fir.bindc_name = "x", fir.optional}) { +subroutine allocatable_array(x) + real, allocatable, optional :: x(:) + ! CHECK: fir.is_present %[[arg0]] : (!fir.ref>>>) -> i1 + print *, present(x) +end subroutine +! CHECK: func @_QMoptPcall_allocatable_array() +subroutine call_allocatable_array() + ! CHECK: %[[x:.*]] = fir.alloca !fir.box>> + real, allocatable :: x(:) + ! CHECK: fir.call @_QMoptPallocatable_array(%[[x]]) : (!fir.ref>>>) -> () + call allocatable_array(x) + ! CHECK: %[[absent:.*]] = fir.absent !fir.ref>>> + ! CHECK: fir.call @_QMoptPallocatable_array(%[[absent]]) : (!fir.ref>>>) -> () + call allocatable_array() +end subroutine + +! CHECK: func @_QMoptPallocatable_to_assumed_optional_array( +! CHECK-SAME: %[[arg0:.*]]: !fir.ref>>>{{.*}}) { +subroutine allocatable_to_assumed_optional_array(x) + real, allocatable :: x(:) + + ! CHECK: %[[xboxload:.*]] = fir.load %[[arg0]] : !fir.ref>>> + ! CHECK: %[[xptr:.*]] = fir.box_addr %[[xboxload]] : (!fir.box>>) -> !fir.heap> + ! CHECK: %[[xaddr:.*]] = fir.convert %[[xptr]] : (!fir.heap>) -> i64 + ! CHECK: %[[isAlloc:.*]] = arith.cmpi ne, %[[xaddr]], %c0{{.*}} : i64 + ! CHECK: %[[absent:.*]] = fir.absent !fir.box> + ! CHECK: %[[embox:.*]] = fir.embox %{{.*}} + ! CHECK: %[[actual:.*]] = arith.select %[[isAlloc]], %[[embox]], %[[absent]] : !fir.box> + ! CHECK: fir.call @_QMoptPassumed_shape(%[[actual]]) : (!fir.box>) -> () + call assumed_shape(x) +end subroutine + +! CHECK-LABEL: func @_QMoptPalloc_component_to_optional_assumed_shape( +subroutine alloc_component_to_optional_assumed_shape(x) + type(t) :: x(100) + ! CHECK-DAG: %[[isAlloc:.*]] = arith.cmpi ne + ! CHECK-DAG: %[[absent:.*]] = fir.absent !fir.box> + ! CHECK: %[[select:.*]] = arith.select %[[isAlloc]], %{{.*}}, %[[absent]] : !fir.box> + ! CHECK: fir.call @_QMoptPassumed_shape(%[[select]]) + call assumed_shape(x(55)%p) +end subroutine + +! CHECK-LABEL: func @_QMoptPalloc_component_eval_only_once( +subroutine alloc_component_eval_only_once(x) + integer, external :: ifoo + type(t) :: x(100) + ! Verify that the index in the component reference are not evaluated twice + ! because if the optional handling logic. + ! CHECK: fir.call @_QPifoo() + ! CHECK-NOT: fir.call @_QPifoo() + call assumed_shape(x(ifoo())%p) +end subroutine + +! CHECK-LABEL: func @_QMoptPnull_as_optional() { +subroutine null_as_optional + ! CHECK: %[[temp:.*]] = fir.alloca !fir.llvm_ptr + ! CHECK: %[[null:.*]] = fir.zero_bits !fir.ref + ! CHECK: fir.store %{{.*}} to %[[temp]] : !fir.ref> + ! CHECK: fir.call @_QMoptPassumed_shape(%{{.*}}) : (!fir.box>) -> () + call assumed_shape(null()) +end subroutine null_as_optional + +end module diff --git a/flang/test/Lower/dummy-arguments.f90 b/flang/test/Lower/dummy-arguments.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Lower/dummy-arguments.f90 @@ -0,0 +1,41 @@ +! RUN: bbc %s -o - | FileCheck %s + +! CHECK-LABEL: _QQmain +program test1 + ! CHECK-DAG: %[[TMP:.*]] = fir.alloca + ! CHECK-DAG: %[[TEN:.*]] = arith.constant + ! CHECK: fir.store %[[TEN]] to %[[TMP]] + ! CHECK-NEXT: fir.call @_QFPfoo + call foo(10) +contains + +! CHECK-LABEL: func @_QFPfoo +subroutine foo(avar1) + integer :: avar1 +! integer :: my_data, my_data2 +! DATA my_data / 150 / +! DATA my_data2 / 150 / +! print *, my_data, my_data2 + print *, avar1 +end subroutine +! CHECK: } +end program test1 + +! CHECK-LABEL: func @_QPsub2 +function sub2(r) + real :: r(20) + ! CHECK: %[[coor:.*]] = fir.coordinate_of %arg0 + ! CHECK: = fir.call @_QPf(%[[coor]]) : (!fir.ref) -> f32 + sub2 = f(r(1)) + ! CHECK: return %{{.*}} : f32 +end function sub2 + +! Test TARGET attribute lowering +! CHECK-LABEL: func @_QPtest_target( +! CHECK-SAME: !fir.ref {fir.bindc_name = "i", fir.target}, +! CHECK-SAME: !fir.box> {fir.bindc_name = "x", fir.target}) +subroutine test_target(i, x) + integer, target :: i + real, target :: x(:) + print *, xs, xa +end subroutine