[flang] Embox derived-type when passed to element procedure as passed object

[clementval]

Summary

In elemental procedure lowering the passed object is always emboxed. The current code
was not correctly dealing with scalar derived-type used as passed object.

[PeteSteinfeld]

All builds and tests correctly and looks goodl.

[jeanPerier]

flang/test/Lower/polymorphic.f90

690

Do you know which passBy this argument is being set to by the Fortran::lower::CallerInterface at https://github.com/llvm/llvm-project/blob/main/flang/lib/Lower/ConvertExpr.cpp#L2591 ?

I did not test, but I find it weird that you have to deal with creating the box in convertWithSemantics(). It suggests to me that passBy may be set to PassBy::BaseAddressValueAttribute when I would expect it to be set to PassBy::Box.

If the same were to happen with arrays or with type with type parameters, the length/shape would be unavailable at that point.

[clementval]

flang/test/Lower/polymorphic.f90

690

In this particular example, it is correct. It's PassBy::Box. I'll update this patch with the correct example where it fails and double check the PassBy behavior.

[clementval]

Fix the actual problem in element procedure lowering

[clementval]

@jeanPerier The issue was actually in genElementalUserDefinedProcRef in the code added in D139537. When the arg is scalar the lowering was not correct.

[jeanPerier]

Makes sense to me now, thanks

flang/lib/Lower/ConvertExpr.cpp

for (const Fortran::lower::CallInterface<
                   iters.iterVec());
               mlir::Value empty;
               mlir::ValueRange emptyRange;
               return builder.create<fir::EmboxOp>(
                   loc, fir::ClassType::get(innerTy), coord, empty, empty,
                   emptyRange, tdesc);
             });
           } else {
-            PushSemantics(ConstituentSemantics::BoxValue);
-            operands.emplace_back(genElementalArgument(*expr));
+            ExtValue exv = asScalarRef(*expr);
+            if (fir::getBase(exv).getType().isa<fir::BaseBoxType>()) {
+              operands.emplace_back(
+                  [=](IterSpace iters) -> ExtValue { return exv; });
+            } else {
+              mlir::Type baseTy =
+                  fir::dyn_cast_ptrOrBoxEleTy(fir::getBase(exv).getType());
+              operands.emplace_back([=](IterSpace iters) -> ExtValue {
+                mlir::Value empty;
+                mlir::ValueRange emptyRange;
+                return builder.create<fir::EmboxOp>(
+                    loc, fir::ClassType::get(baseTy), fir::getBase(exv), empty,
+                    empty, emptyRange);
+              });
+            }
           }
           break;
         }
         // See C15100 and C15101
         fir::emitFatalError(loc, "cannot be POINTER, ALLOCATABLE");
       }
     }
 

flang/test/Lower/polymorphic.f90

 ! RUN: bbc -polymorphic-type -emit-fir %s -o - | FileCheck %s
 
 ! Tests various aspect of the lowering of polymorphic entities.
 
 module polymorphic_test
   type p1
     integer :: a
     integer :: b
   contains
     procedure :: print
     procedure :: assign_p1_int
     procedure :: elemental_fct
     procedure :: elemental_sub
     procedure, pass(this) :: elemental_sub_pass
     generic :: assignment(=) => assign_p1_int
     procedure :: host_assoc
+    procedure, pass(poly) :: lt
+    generic :: operator(<) => lt
   end type
 
   type, extends(p1) :: p2
     real :: c
   end type
 
   type r1
     real, pointer :: rp(:) => null()
   end type
 
   type c1
     character(2) :: tmp = 'c1'
   contains
     procedure :: get_tmp
   end type
 
   type p3
     class(p3), pointer :: p(:)
   end type
 
+  type outer
+    type(p1) :: inner
+  end type
+
   contains
 
   elemental subroutine assign_p1_int(lhs, rhs)
     class(p1), intent(inout) :: lhs
     integer, intent(in) :: rhs
     lhs%a = rhs
     lhs%b = rhs
   End Subroutine
! CHECK: fir.call @_QMpolymorphic_testFhost_assocPinternal(%[[TUPLE]]) {{.*}} : (!fir.ref<tuple<!fir.class<!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>>>) -> ()
   end subroutine
 
   elemental subroutine elemental_sub_pass(c, this)
     integer, intent(in) :: c
     class(p1), intent(inout) :: this
     this%a = this%a * this%b + c
   end subroutine
 
+  logical elemental function lt(i, poly)
+    integer, intent(in) :: i
+    class(p1), intent(in) :: poly
+    lt = i < poly%a
+  End Function
+
   ! Test correct access to polymorphic entity component.
   subroutine component_access(p)
     class(p1) :: p
     print*, p%a
   end subroutine
 
 ! CHECK-LABEL: func.func @_QMpolymorphic_testPcomponent_access(
 ! CHECK-SAME: %[[P:.*]]: !fir.class<!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>> {fir.bindc_name = "p"}) {

 ! CHECK: %[[UB:.*]] = arith.subi %[[P_DIMS]]#1, %[[C1]] : index
 ! CHECK: fir.do_loop %[[IND:.*]] = %[[C0]] to %[[UB]] step %[[C1]] {
 ! CHECK:   %[[COORD:.*]] = fir.coordinate_of %[[P]], %[[IND]] : (!fir.class<!fir.array<?x!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>>, index) -> !fir.ref<!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>
 ! CHECK:   %[[EMBOXED:.*]] = fir.embox %[[COORD]] tdesc %[[TDESC]] : (!fir.ref<!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>, !fir.tdesc<none>) -> !fir.class<!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>
 ! CHECK:   fir.dispatch "elemental_sub_pass"(%[[EMBOXED]] : !fir.class<!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>) (%{{.*}}, %[[EMBOXED]] : !fir.ref<i32>, !fir.class<!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>) {pass_arg_pos = 1 : i32}
 ! CHECK: }
 
 end module
+
+program test
+  use polymorphic_test
+  type(outer), allocatable :: o
+  integer :: i(5)
+  logical :: l(5)
+  allocate(o)
+
+  l = i < o%inner
+end program
+
+! CHECK-LABEL: func.func @_QQmain() {
+! CHECK: %[[ADDR_O:.*]] = fir.address_of(@_QFEo) : !fir.ref<!fir.box<!fir.heap<!fir.type<_QMpolymorphic_testTouter{inner:!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>}>>>>
+! CHECK: %[[BOX_NONE:.*]] = fir.convert %[[ADDR_O]] : (!fir.ref<!fir.box<!fir.heap<!fir.type<_QMpolymorphic_testTouter{inner:!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>}>>>>) -> !fir.ref<!fir.box<none>>
+! CHECK: %{{.*}} = fir.call @_FortranAAllocatableAllocate(%[[BOX_NONE]], %{{.*}}, %{{.*}}, %{{.*}}, %{{.*}}) {{.*}} : (!fir.ref<!fir.box<none>>, i1, !fir.box<none>, !fir.ref<i8>, i32) -> i32
+! CHECK: %[[O:.*]] = fir.load %[[ADDR_O]] : !fir.ref<!fir.box<!fir.heap<!fir.type<_QMpolymorphic_testTouter{inner:!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>}>>>>
+! CHECK: %[[FIELD_INNER:.*]] = fir.field_index inner, !fir.type<_QMpolymorphic_testTouter{inner:!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>}>
+! CHECK: %[[COORD_INNER:.*]] = fir.coordinate_of %[[O]], %[[FIELD_INNER]] : (!fir.box<!fir.heap<!fir.type<_QMpolymorphic_testTouter{inner:!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>}>>>, !fir.field) -> !fir.ref<!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>
+! CHECK: %{{.*}} = fir.do_loop %{{.*}} = %{{.*}} to %{{.*}} step %{{.*}} unordered iter_args(%arg1 = %9) -> (!fir.array<5x!fir.logical<4>>) {
+! CHECK:   %[[EMBOXED:.*]] = fir.embox %[[COORD_INNER]] : (!fir.ref<!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>) -> !fir.class<!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>
+! CHECK:   %{{.*}} = fir.call @_QMpolymorphic_testPlt(%17, %[[EMBOXED]]) {{.*}} : (!fir.ref<i32>, !fir.class<!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>) -> !fir.logical<4>
+! CHECK:  }