diff --git a/flang/include/flang/Optimizer/Dialect/FIROps.td b/flang/include/flang/Optimizer/Dialect/FIROps.td --- a/flang/include/flang/Optimizer/Dialect/FIROps.td +++ b/flang/include/flang/Optimizer/Dialect/FIROps.td @@ -1009,7 +1009,7 @@ are the values encoded in a standard descriptor. }]; - let arguments = (ins fir_BoxType:$val, AnyIntegerLike:$dim); + let arguments = (ins BoxOrClassType:$val, AnyIntegerLike:$dim); let results = (outs Index, Index, Index); diff --git a/flang/lib/Lower/ConvertVariable.cpp b/flang/lib/Lower/ConvertVariable.cpp --- a/flang/lib/Lower/ConvertVariable.cpp +++ b/flang/lib/Lower/ConvertVariable.cpp @@ -1149,7 +1149,7 @@ static bool lowerToBoxValue(const Fortran::semantics::Symbol &sym, mlir::Value dummyArg) { // Only dummy arguments coming as fir.box can be tracked in an BoxValue. - if (!dummyArg || !dummyArg.getType().isa()) + if (!dummyArg || !dummyArg.getType().isa()) return false; // Non contiguous arrays must be tracked in an BoxValue. if (sym.Rank() > 0 && !sym.attrs().test(Fortran::semantics::Attr::CONTIGUOUS)) diff --git a/flang/lib/Optimizer/Builder/FIRBuilder.cpp b/flang/lib/Optimizer/Builder/FIRBuilder.cpp --- a/flang/lib/Optimizer/Builder/FIRBuilder.cpp +++ b/flang/lib/Optimizer/Builder/FIRBuilder.cpp @@ -477,8 +477,23 @@ llvm_unreachable("not a memory reference type"); } mlir::Type boxTy = fir::BoxType::get(elementType); - if (isPolymorphic) + mlir::Value tdesc; + if (isPolymorphic) { boxTy = fir::ClassType::get(elementType); + + // Look for the original tdesc for the new box. + if (auto *op = itemAddr.getDefiningOp()) { + if (auto coordOp = mlir::dyn_cast(op)) { + if (fir::isPolymorphicType(coordOp.getBaseType())) { + mlir::Type resultType = coordOp.getResult().getType(); + mlir::Type tdescType = + fir::TypeDescType::get(fir::unwrapRefType(resultType)); + tdesc = create(loc, tdescType, coordOp.getRef()); + } + } + } + } + return exv.match( [&](const fir::ArrayBoxValue &box) -> mlir::Value { mlir::Value s = createShape(loc, exv); @@ -507,7 +522,10 @@ loc, fir::factory::getMutableIRBox(*this, loc, x)); }, [&](const auto &) -> mlir::Value { - return create(loc, boxTy, itemAddr); + mlir::Value empty; + mlir::ValueRange emptyRange; + return create(loc, boxTy, itemAddr, empty, empty, + emptyRange, tdesc); }); } diff --git a/flang/test/Lower/dispatch.f90 b/flang/test/Lower/dispatch.f90 --- a/flang/test/Lower/dispatch.f90 +++ b/flang/test/Lower/dispatch.f90 @@ -28,6 +28,8 @@ procedure :: p1_fct2 procedure, pass(this) :: p1_fct3_arg0 procedure, pass(this) :: p1_fct4_arg1 + + procedure :: pass_with_class_arg end type type, abstract :: a1 @@ -67,6 +69,12 @@ end function ! CHECK-LABEL: func.func @_QMcall_dispatchPp1_fct4_arg1(%{{.*}}: !fir.ref, %{{.*}}: !fir.class>) -> f32 + subroutine pass_with_class_arg(this, other) + class(p1) :: this + class(p1) :: other + end subroutine + ! CHECK-LABEL: func.func @_QMcall_dispatchPpass_with_class_arg(%{{.*}}: !fir.class>, %{{.*}}: !fir.class>) { + subroutine p1_proc1_nopass() end subroutine ! CHECK-LABEL: func.func @_QMcall_dispatchPp1_proc1_nopass() @@ -177,6 +185,150 @@ ! CHECK: %[[REBOX:.*]] = fir.rebox %[[LOAD]] : (!fir.class>>) -> !fir.class> ! CHECK: fir.dispatch "tbp_pass"(%[[REBOX]] : !fir.class>) (%1 : !fir.class>) {pass_arg_pos = 0 : i32} + subroutine check_dispatch_static_array(p, t) + class(p1) :: p(10) + type(p1) :: t(10) + integer :: i + do i = 1, 10 + call p(i)%tbp_pass() + end do + + do i = 1, 10 + call t(i)%tbp_pass() + end do + end subroutine + +! CHECK-LABEL: func.func @_QMcall_dispatchPcheck_dispatch_static_array( +! CHECK-SAME: %[[ARG0:.*]]: !fir.class>> {fir.bindc_name = "p"}, +! CHECK-SAME: %[[ARG1:.*]]: !fir.ref>> {fir.bindc_name = "t"}) { +! CHECK: fir.do_loop {{.*}} { +! CHECK: %[[COORD:.*]] = fir.coordinate_of %[[ARG0]], %{{.*}} : (!fir.class>>, i64) -> !fir.ref> +! CHECK: %[[TDESC:.*]] = fir.box_tdesc %[[ARG0]] : (!fir.class>>) -> !fir.tdesc> +! CHECK: %[[CLASS_BOX:.*]] = fir.embox %[[COORD]] tdesc %[[TDESC]] : (!fir.ref>, !fir.tdesc>) -> !fir.class> +! CHECK: fir.dispatch "tbp_pass"(%[[CLASS_BOX]] : !fir.class>) (%[[CLASS_BOX]] : !fir.class>) {pass_arg_pos = 0 : i32} + +! CHECK: fir.do_loop {{.*}} { +! CHECK: %[[COORD1:.*]] = fir.coordinate_of %[[ARG1]], %{{.*}} : (!fir.ref>>, i64) -> !fir.ref> +! CHECK: %[[EMBOX:.*]] = fir.embox %[[COORD]] : (!fir.ref>) -> !fir.class> +! CHECK: fir.call @_QMcall_dispatchPtbp_pass(%[[EMBOX]]) : (!fir.class>) -> () + + subroutine check_dispatch_dynamic_array(p, t) + class(p1) :: p(:) + type(p1) :: t(:) + integer :: i + do i = 1, 10 + call p(i)%tbp_pass() + end do + + do i = 1, 10 + call t(i)%tbp_pass() + end do + end subroutine + +! CHECK-LABEL: func.func @_QMcall_dispatchPcheck_dispatch_dynamic_array( +! CHECK-SAME: %[[ARG0:.*]]: !fir.class>> {fir.bindc_name = "p"}, +! CHECK-SAME: %[[ARG1:.*]]: !fir.box>> {fir.bindc_name = "t"}) { +! CHECK: %{{.*}} = fir.do_loop {{.*}} { +! CHECK: %[[COORD:.*]] = fir.coordinate_of %[[ARG0]], %{{.*}} : (!fir.class>>, i64) -> !fir.ref> +! CHECK: %[[TDESC:.*]] = fir.box_tdesc %[[ARG0]] : (!fir.class>>) -> !fir.tdesc> +! CHECK: %[[CLASS_BOX:.*]] = fir.embox %[[COORD]] tdesc %[[TDESC]] : (!fir.ref>, !fir.tdesc>) -> !fir.class> +! CHECK: fir.dispatch "tbp_pass"(%[[CLASS_BOX]] : !fir.class>) (%[[CLASS_BOX]] : !fir.class>) {pass_arg_pos = 0 : i32} + +! CHECK: %{{.*}} = fir.do_loop {{.*}} { +! CHECK: %[[COORD:.*]] = fir.coordinate_of %[[ARG1]], %{{.*}} : (!fir.box>>, i64) -> !fir.ref> +! CHECK: %[[EMBOX:.*]] = fir.embox %[[COORD]] : (!fir.ref>) -> !fir.class> +! CHECK: fir.call @_QMcall_dispatchPtbp_pass(%[[EMBOX]]) : (!fir.class>) -> () + + subroutine check_dispatch_allocatable_array(p, t) + class(p1), allocatable :: p(:) + type(p1), allocatable :: t(:) + integer :: i + do i = 1, 10 + call p(i)%tbp_pass() + end do + + do i = 1, 10 + call t(i)%tbp_pass() + end do + end subroutine + +! CHECK-LABEL: func.func @_QMcall_dispatchPcheck_dispatch_allocatable_array( +! CHECK-SAME: %[[ARG0:.*]]: !fir.ref>>>> {fir.bindc_name = "p"}, +! CHECK-SAME: %[[ARG1:.*]]: !fir.ref>>>> {fir.bindc_name = "t"}) { +! CHECK: %{{.*}} = fir.do_loop {{.*}} { +! CHECK: fir.store %arg3 to %0 : !fir.ref +! CHECK: %[[LOAD_ARG0:.*]] = fir.load %[[ARG0]] : !fir.ref>>>> +! CHECK: %[[C0:.*]] = arith.constant 0 : index +! CHECK: %[[BOX_DIMS_ARG0:.*]]:3 = fir.box_dims %[[LOAD_ARG0]], %[[C0]] : (!fir.class>>>, index) -> (index, index, index) +! CHECK: %[[COORD:.*]] = fir.coordinate_of %[[LOAD_ARG0]], %{{.*}} : (!fir.class>>>, i64) -> !fir.ref> +! CHECK: %[[TDESC_ARG0:.*]] = fir.box_tdesc %[[LOAD_ARG0]] : (!fir.class>>>) -> !fir.tdesc> +! CHECK: %[[CLASS_BOX:.*]] = fir.embox %[[COORD]] tdesc %[[TDESC_ARG0]] : (!fir.ref>, !fir.tdesc>) -> !fir.class> +! CHECK: fir.dispatch "tbp_pass"(%[[CLASS_BOX]] : !fir.class>) (%[[CLASS_BOX]] : !fir.class>) {pass_arg_pos = 0 : i32} + +! CHECK: %{{.*}} = fir.do_loop {{.*}} { +! CHECK: %[[LOAD_ARG1:.*]] = fir.load %[[ARG1]] : !fir.ref>>>> +! CHECK: %[[C0:.*]] = arith.constant 0 : index +! CHECK: %[[BOX_DIMS_ARG1:.*]]:3 = fir.box_dims %[[LOAD_ARG1]], %[[C0]] : (!fir.box>>>, index) -> (index, index, index) +! CHECK: %[[COORD:.*]] = fir.coordinate_of %[[LOAD_ARG1]], %{{.*}} : (!fir.box>>>, i64) -> !fir.ref> +! CHECK: %[[EMBOX:.*]] = fir.embox %[[COORD]] : (!fir.ref>) -> !fir.class> +! CHECK: fir.call @_QMcall_dispatchPtbp_pass(%[[EMBOX]]) : (!fir.class>) -> () + + subroutine check_dispatch_pointer_array(p, t) + class(p1), pointer :: p(:) + type(p1), pointer :: t(:) + integer :: i + do i = 1, 10 + call p(i)%tbp_pass() + end do + + do i = 1, 10 + call t(i)%tbp_pass() + end do + end subroutine + +! CHECK-LABEL: func.func @_QMcall_dispatchPcheck_dispatch_pointer_array( +! CHECK-SAME: %[[ARG0:.*]]: !fir.ref>>>> {fir.bindc_name = "p"}, +! CHECK-SAME: %[[ARG1:.*]]: !fir.ref>>>> {fir.bindc_name = "t"}) { + +! CHECK: %{{.*}} = fir.do_loop {{.*}} { +! CHECK: %[[LOAD_ARG0:.*]] = fir.load %[[ARG0]] : !fir.ref>>>> +! CHECK: %[[C0:.*]] = arith.constant 0 : index +! CHECK: %[[BOX_DIMS_ARG0]]:3 = fir.box_dims %[[LOAD_ARG0]], %[[C0]] : (!fir.class>>>, index) -> (index, index, index) +! CHECK: %[[COORD:.*]] = fir.coordinate_of %[[LOAD_ARG0]], %{{.*}} : (!fir.class>>>, i64) -> !fir.ref> +! CHECK: %[[TDESC_ARG0:.*]] = fir.box_tdesc %[[LOAD_ARG0]] : (!fir.class>>>) -> !fir.tdesc> +! CHECK: %[[CLASS_BOX]] = fir.embox %[[COORD]] tdesc %[[TDESC_ARG0]] : (!fir.ref>, !fir.tdesc>) -> !fir.class> +! CHECK: fir.dispatch "tbp_pass"(%[[CLASS_BOX]] : !fir.class>) (%[[CLASS_BOX]] : !fir.class>) {pass_arg_pos = 0 : i32} + +! CHECK: %{{.*}} = fir.do_loop {{.*}} { +! CHECK: %[[LOAD_ARG1:.*]] = fir.load %[[ARG1]] : !fir.ref>>>> +! CHECK: %[[C0:.*]] = arith.constant 0 : index +! CHECK: %[[BOX_DIMS_ARG1:.*]]:3 = fir.box_dims %[[LOAD_ARG1]], %[[C0]] : (!fir.box>>>, index) -> (index, index, index) +! CHECK: %[[COORD:.*]] = fir.coordinate_of %[[LOAD_ARG1]], %{{.*}} : (!fir.box>>>, i64) -> !fir.ref> +! CHECK: %[[EMBOX:.*]] = fir.embox %[[COORD]] : (!fir.ref>) -> !fir.class> +! CHECK: fir.call @_QMcall_dispatchPtbp_pass(%[[EMBOX]]) : (!fir.class>) -> () + + subroutine check_dispatch_dynamic_array_copy(p, o) + class(p1) :: p(:) + class(p1) :: o(:) + + integer :: i + do i = 1, 9 + call p(i)%pass_with_class_arg(o(i+1)) + end do + end subroutine + +! CHECK-LABEL: func.func @_QMcall_dispatchPcheck_dispatch_dynamic_array_copy( +! CHECK-SAME: %[[ARG0:.*]]: !fir.class>> {fir.bindc_name = "p"}, +! CHECK-SAME: %[[ARG1:.*]]: !fir.class>> {fir.bindc_name = "o"}) { +! CHECK: %{{.*}} = fir.do_loop {{.*}} { +! CHECK: %[[COORD1:.*]] = fir.coordinate_of %[[ARG0]], %{{.*}} : (!fir.class>>, i64) -> !fir.ref> +! CHECK: %[[TDESC1:.*]] = fir.box_tdesc %[[ARG0]] : (!fir.class>>) -> !fir.tdesc> +! CHECK: %[[CLASS1:.*]] = fir.embox %[[COORD1]] tdesc %[[TDESC1]] : (!fir.ref>, !fir.tdesc>) -> !fir.class> +! CHECK: %[[COORD2:.*]] = fir.coordinate_of %[[ARG1]], %{{.*}} : (!fir.class>>, i64) -> !fir.ref> +! CHECK: %[[TDESC2:.*]] = fir.box_tdesc %[[ARG1]] : (!fir.class>>) -> !fir.tdesc> +! CHECK: %[[CLASS2:.*]] = fir.embox %[[COORD2]] tdesc %[[TDESC2]] : (!fir.ref>, !fir.tdesc>) -> !fir.class> +! CHECK: fir.dispatch "pass_with_class_arg"(%[[CLASS1]] : !fir.class>) (%[[CLASS1]], %[[CLASS2]] : !fir.class>, !fir.class>) {pass_arg_pos = 0 : i32} + ! ------------------------------------------------------------------------------ ! Test that direct call is emitted when the type is known ! ------------------------------------------------------------------------------