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

[Valentin Clement via flang-commits]

Author: Valentin Clement
Date: 2022-12-09T15:37:56+01:00
New Revision: 1b410745081dadae7a9a11b3939c06fed377fda0

URL: https://github.com/llvm/llvm-project/commit/1b410745081dadae7a9a11b3939c06fed377fda0
DIFF: https://github.com/llvm/llvm-project/commit/1b410745081dadae7a9a11b3939c06fed377fda0.diff

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

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.

Reviewed By: jeanPerier, PeteSteinfeld

Differential Revision: https://reviews.llvm.org/D139667

Added: 
    

Modified: 
    flang/lib/Lower/ConvertExpr.cpp
    flang/test/Lower/polymorphic.f90

Removed: 
    


################################################################################
diff  --git a/flang/lib/Lower/ConvertExpr.cpp b/flang/lib/Lower/ConvertExpr.cpp
index c1d103ab7f228..93aec925bbe6f 100644
--- a/flang/lib/Lower/ConvertExpr.cpp
+++ b/flang/lib/Lower/ConvertExpr.cpp
@@ -4718,8 +4718,21 @@ class ArrayExprLowering {
                   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;
         }

diff  --git a/flang/test/Lower/polymorphic.f90 b/flang/test/Lower/polymorphic.f90
index ce0297eba8e2c..7fa7d3e941203 100644
--- a/flang/test/Lower/polymorphic.f90
+++ b/flang/test/Lower/polymorphic.f90
@@ -14,6 +14,8 @@ module polymorphic_test
     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
@@ -34,6 +36,10 @@ module polymorphic_test
     class(p3), pointer :: p(:)
   end type
 
+  type outer
+    type(p1) :: inner
+  end type
+
   contains
 
   elemental subroutine assign_p1_int(lhs, rhs)
@@ -67,6 +73,12 @@ elemental subroutine elemental_sub_pass(c, 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
@@ -670,3 +682,25 @@ subroutine test_elemental_sub_poly_array_assumed(p)
 ! 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:  }