[flang] Use AssignPolymorphic when LHS is polymorphic

[clementval]

Summary

Make use of the new runtime entry point for assignment to
LHS allocatable polymorphic.

[jeanPerier]

LGTM

flang/include/flang/Optimizer/Builder/Runtime/Assign.h

 /// Generate runtime call to assign \p sourceBox to \p destBox.
 /// \p destBox must be a fir.ref<fir.box<T>> and \p sourceBox a fir.box<T>.
 /// \p destBox Fortran descriptor may be modified if destBox is an allocatable
 /// according to Fortran allocatable assignment rules, otherwise it is not
 /// modified.
 void genAssign(fir::FirOpBuilder &builder, mlir::Location loc,
                mlir::Value destBox, mlir::Value sourceBox);
 
+/// Generate runtime call to AssignPolymorphic \p sourceBox to \p destBox.
+/// \p destBox must be a fir.ref<fir.box<T>> and \p sourceBox a fir.box<T>.
+/// \p destBox Fortran descriptor may be modified if destBox is an allocatable
+/// according to Fortran allocatable assignment rules.
+void genAssignPolymorphic(fir::FirOpBuilder &builder, mlir::Location loc,
+                          mlir::Value destBox, mlir::Value sourceBox);
+
 } // namespace fir::runtime
 #endif // FORTRAN_OPTIMIZER_BUILDER_RUNTIME_ASSIGN_H

flang/lib/Lower/Bridge.cpp

std::visit(
                                rhsType->IsUnlimitedPolymorphic()))) {
                 mlir::Value lhs;
                 if (Fortran::lower::isWholeAllocatable(assign.lhs))
                   lhs = genExprMutableBox(loc, assign.lhs).getAddr();
                 else
                   lhs = fir::getBase(genExprBox(loc, assign.lhs, stmtCtx));
                 mlir::Value rhs =
                     fir::getBase(genExprBox(loc, assign.rhs, stmtCtx));
+                if ((lhsType->IsPolymorphic() ||
+                     lhsType->IsUnlimitedPolymorphic()) &&
+                    Fortran::lower::isWholeAllocatable(assign.lhs))
+                  fir::runtime::genAssignPolymorphic(*builder, loc, lhs, rhs);
+                else
                   fir::runtime::genAssign(*builder, loc, lhs, rhs);
                 return;
               }
 
               // Note: No ad-hoc handling for pointers is required here. The
               // target will be assigned as per 2018 10.2.1.3 p2. genExprAddr
               // on a pointer returns the target address and not the address of
               // the pointer variable.
 

flang/lib/Optimizer/Builder/Runtime/Assign.cpp

void fir::runtime::genAssign(fir::FirOpBuilder &builder, mlir::Location loc,
   auto fTy = func.getFunctionType();
   auto sourceFile = fir::factory::locationToFilename(builder, loc);
   auto sourceLine =
       fir::factory::locationToLineNo(builder, loc, fTy.getInput(3));
   auto args = fir::runtime::createArguments(builder, loc, fTy, destBox,
                                             sourceBox, sourceFile, sourceLine);
   builder.create<fir::CallOp>(loc, func, args);
 }
+
+void fir::runtime::genAssignPolymorphic(fir::FirOpBuilder &builder,
+                                        mlir::Location loc, mlir::Value destBox,
+                                        mlir::Value sourceBox) {
+  auto func =
+      fir::runtime::getRuntimeFunc<mkRTKey(AssignPolymorphic)>(loc, builder);
+  auto fTy = func.getFunctionType();
+  auto sourceFile = fir::factory::locationToFilename(builder, loc);
+  auto sourceLine =
+      fir::factory::locationToLineNo(builder, loc, fTy.getInput(3));
+  auto args = fir::runtime::createArguments(builder, loc, fTy, destBox,
+                                            sourceBox, sourceFile, sourceLine);
+  builder.create<fir::CallOp>(loc, func, args);
+}

flang/test/Lower/polymorphic.f90

 ! CHECK: fir.store %[[EMBOX]] to %[[C]] : !fir.ref<!fir.class<!fir.heap<!fir.array<?x?x!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>>>>
 ! CHECK: %[[C10:.*]] = arith.constant 10 : index
 ! CHECK: %[[C20:.*]] = arith.constant 20 : index
 ! CHECK: %[[T:.*]] = fir.alloca !fir.array<10x20x!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>> {bindc_name = "t", fir.target, uniq_name = "_QMpolymorphic_testFassign_polymorphic_allocatableEt"}
 ! CHECK: %[[SHAPE:.*]] = fir.shape %[[C10]], %[[C20]] : (index, index) -> !fir.shape<2>
 ! CHECK: %[[BOXED_T:.*]] = fir.embox %[[T]](%[[SHAPE]]) : (!fir.ref<!fir.array<10x20x!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>>, !fir.shape<2>) -> !fir.box<!fir.array<10x20x!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>>
 ! CHECK: %[[CONV_C:.*]] = fir.convert %[[C]] : (!fir.ref<!fir.class<!fir.heap<!fir.array<?x?x!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>>>>) -> !fir.ref<!fir.box<none>>
 ! CHECK: %[[CONV_BOXED_T:.*]] = fir.convert %[[BOXED_T]] : (!fir.box<!fir.array<10x20x!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>>) -> !fir.box<none>
-! CHECK: %{{.*}} = fir.call @_FortranAAssign(%[[CONV_C]], %[[CONV_BOXED_T]], %{{.*}}, %{{.*}}) fastmath<contract> : (!fir.ref<!fir.box<none>>, !fir.box<none>, !fir.ref<i8>, i32) -> none
+! CHECK: %{{.*}} = fir.call @_FortranAAssignPolymorphic(%[[CONV_C]], %[[CONV_BOXED_T]], %{{.*}}, %{{.*}}) fastmath<contract> : (!fir.ref<!fir.box<none>>, !fir.box<none>, !fir.ref<i8>, i32) -> none
 ! CHECK: return
 
   subroutine pointer_assign_remap()
     class(p1), pointer :: a(:)
     class(p1), pointer :: p(:,:)
     class(p1), pointer :: q(:)
     allocate(a(100))
     p(1:10,1:10) => a