[flang] Delegate pointer association to class(*) pointer to the runtime

[clementval]

Summary

Pointer association with an unlimited polymorphic pointer on the lhs
requires more than just updating the base_addr. Delegate the association to
the runtime function PointerAssociation.

[PeteSteinfeld]

All builds and tests correctly and looks good.

[jeanPerier]

flang/lib/Lower/Bridge.cpp

2721

Does the right hand side always have to be an allocatable/pointer if the left hand side is unlimited polymorphic ? If so, I think it would be worth adding a standard reference here.

flang/test/Lower/polymorphic.f90

145

Sorry, I misunderstood your question earlier. I do not think it is OK to allow convertion from fir.ref<fir.box<>> to fir.box<none>. It is cheating the SSA value model of fir.box. Any following code would thing the convert results is immutable while it is not since the convert operand can be modified.

So I think you have to load and then cast to a fir.box<None> here. I know that will imply making a copy of the descriptor, which is useless here, but we should fix that in a more generic way by skipping the copy in the fir.load codegen if we know we can.

[clementval]

flang/test/Lower/polymorphic.f90

145

Makes sense. I'll update the code to include the load if necessary.

flang/include/flang/Lower/Runtime.h

void genSyncMemoryStatement(AbstractConverter &,
                             const parser::SyncMemoryStmt &);
 void genSyncTeamStatement(AbstractConverter &, const parser::SyncTeamStmt &);
 void genUnlockStatement(AbstractConverter &, const parser::UnlockStmt &);
 void genPauseStatement(AbstractConverter &, const parser::PauseStmt &);
 
 mlir::Value genAssociated(fir::FirOpBuilder &, mlir::Location,
                           mlir::Value pointer, mlir::Value target);
 
+void genPointerAssociate(fir::FirOpBuilder &, mlir::Location,
+                         mlir::Value pointer, mlir::Value target);
+
 mlir::Value genCpuTime(fir::FirOpBuilder &, mlir::Location);
 void genDateAndTime(fir::FirOpBuilder &, mlir::Location,
                     llvm::Optional<fir::CharBoxValue> date,
                     llvm::Optional<fir::CharBoxValue> time,
                     llvm::Optional<fir::CharBoxValue> zone, mlir::Value values);
 
 void genRandomInit(fir::FirOpBuilder &, mlir::Location, mlir::Value repeatable,
                    mlir::Value imageDistinct);

flang/include/flang/Optimizer/Dialect/FIRType.h

 
 /// Return true iff `ty` is the type of an ALLOCATABLE entity or value.
 bool isAllocatableType(mlir::Type ty);
 
 /// Return true iff `ty` is the type of a boxed record type.
 /// e.g. !fir.box<!fir.type<derived>>
 bool isBoxedRecordType(mlir::Type ty);
 
+/// Return true iff `ty` is a !fir.ref<!fir.box<T>> type.
+bool isRefBoxType(mlir::Type ty);
+
+/// Return true iff `ty` is !fir.box<none> type.
+bool isOpaqueDescType(mlir::Type ty);
+
 /// Return true iff `ty` is the type of an polymorphic entity or
 /// value.
 bool isPolymorphicType(mlir::Type ty);
 
 /// Return true iff `ty` is the type of an unlimited polymorphic entity or
 /// value.
 bool isUnlimitedPolymorphicType(mlir::Type ty);
 

flang/lib/Lower/Bridge.cpp

std::visit(
                   localSymbols, ctx, /*isUserDefAssignment=*/true);
             },
 
             // [3] Pointer assignment with possibly empty bounds-spec. R1035: a
             // bounds-spec is a lower bound value.
             [&](const Fortran::evaluate::Assignment::BoundsSpec &lbExprs) {
               if (Fortran::evaluate::IsProcedure(assign.rhs))
                 TODO(loc, "procedure pointer assignment");
+
+              std::optional<Fortran::evaluate::DynamicType> lhsType =
+                  assign.lhs.GetType();
+              // Delegate pointer association to unlimited polymorphic pointer
+              // to the runtime. element size, type code, attribute and of
+              // course base_addr might need to be updated.
+              if (lhsType && lhsType->IsUnlimitedPolymorphic()) {
+                mlir::Value lhs = genExprMutableBox(loc, assign.lhs).getAddr();
+                mlir::Value rhs = genExprMutableBox(loc, assign.rhs).getAddr();
+                Fortran::lower::genPointerAssociate(*builder, loc, lhs, rhs);
+                return;
+              }
+
               llvm::SmallVector<mlir::Value> lbounds;
               for (const Fortran::evaluate::ExtentExpr &lbExpr : lbExprs)
                 lbounds.push_back(
                     fir::getBase(genExprValue(toEvExpr(lbExpr), stmtCtx)));
               if (explicitIterationSpace()) {
                 // Pointer assignment in FORALL context. Copy the rhs box value
                 // into the lhs box variable.
                 genArrayAssignment(assign, stmtCtx, lbounds);

flang/lib/Lower/Runtime.cpp

mlir::Value Fortran::lower::genAssociated(fir::FirOpBuilder &builder,
   mlir::func::FuncOp func =
       fir::runtime::getRuntimeFunc<mkRTKey(PointerIsAssociatedWith)>(loc,
                                                                      builder);
   llvm::SmallVector<mlir::Value> args = fir::runtime::createArguments(
       builder, loc, func.getFunctionType(), pointer, target);
   return builder.create<fir::CallOp>(loc, func, args).getResult(0);
 }
 
+void Fortran::lower::genPointerAssociate(fir::FirOpBuilder &builder,
+                                         mlir::Location loc,
+                                         mlir::Value pointer,
+                                         mlir::Value target) {
+  mlir::func::FuncOp func =
+      fir::runtime::getRuntimeFunc<mkRTKey(PointerAssociate)>(loc, builder);
+  llvm::SmallVector<mlir::Value> args = fir::runtime::createArguments(
+      builder, loc, func.getFunctionType(), pointer, target);
+  builder.create<fir::CallOp>(loc, func, args).getResult(0);
+}
+
 mlir::Value Fortran::lower::genCpuTime(fir::FirOpBuilder &builder,
                                        mlir::Location loc) {
   mlir::func::FuncOp func =
       fir::runtime::getRuntimeFunc<mkRTKey(CpuTime)>(loc, builder);
   return builder.create<fir::CallOp>(loc, func, llvm::None).getResult(0);
 }
 
 void Fortran::lower::genDateAndTime(fir::FirOpBuilder &builder,

flang/lib/Optimizer/Dialect/FIROps.cpp

if ((isPointerCompatible(inType) && isPointerCompatible(outType)) ||
       (isFloatCompatible(inType) && isIntegerCompatible(outType)) ||
       (isFloatCompatible(inType) && isFloatCompatible(outType)) ||
       (isIntegerCompatible(inType) && isPointerCompatible(outType)) ||
       (isPointerCompatible(inType) && isIntegerCompatible(outType)) ||
       (inType.isa<fir::BoxType>() && outType.isa<fir::BoxType>()) ||
       (inType.isa<fir::BoxProcType>() && outType.isa<fir::BoxProcType>()) ||
       (fir::isa_complex(inType) && fir::isa_complex(outType)) ||
       (fir::isBoxedRecordType(inType) && fir::isPolymorphicType(outType)) ||
-      (fir::isPolymorphicType(inType) && fir::isPolymorphicType(outType)))
+      (fir::isPolymorphicType(inType) && fir::isPolymorphicType(outType)) ||
+      (fir::isRefBoxType(inType) && fir::isOpaqueDescType(outType)))
     return mlir::success();
+  llvm::errs() << inType << " / " << outType << "\n";
   return emitOpError("invalid type conversion");
 }
 
 //===----------------------------------------------------------------------===//
 // CoordinateOp
 //===----------------------------------------------------------------------===//
 
 void fir::CoordinateOp::print(mlir::OpAsmPrinter &p) {

flang/lib/Optimizer/Dialect/FIRType.cpp

if (auto boxTy = ty.dyn_cast<fir::BoxType>()) {
     if (boxTy.getEleTy().isa<fir::RecordType>())
       return true;
     mlir::Type innerType = boxTy.unwrapInnerType();
     return innerType && innerType.isa<fir::RecordType>();
   }
   return false;
 }
 
+bool isRefBoxType(mlir::Type ty) {
+  if (auto refTy = ty.dyn_cast<fir::ReferenceType>())
+    return refTy.getEleTy().isa<fir::BaseBoxType>();
+  return false;
+}
+
+bool isOpaqueDescType(mlir::Type ty) {
+  if (auto boxTy = ty.dyn_cast<fir::BoxType>())
+    if (boxTy.getEleTy().isa<mlir::NoneType>())
+      return true;
+  return false;
+}
+
 static bool isAssumedType(mlir::Type ty) {
   if (auto boxTy = ty.dyn_cast<fir::BoxType>()) {
     if (boxTy.getEleTy().isa<mlir::NoneType>())
       return true;
     if (auto seqTy = boxTy.getEleTy().dyn_cast<fir::SequenceType>())
       return seqTy.getEleTy().isa<mlir::NoneType>();
   }
   return false;

flang/test/Lower/polymorphic.f90

! CHECK-LABEL: func.func @_QMpolymorphic_testPup_ret() -> !fir.class<!fir.ptr<!fir.array<?xnone>>> {
   subroutine call_up_ret()
     class(*), pointer :: p(:)
     p => up_ret()
   end subroutine
 
 ! CHECK-LABEL: func.func @_QMpolymorphic_testPcall_up_ret() {
 ! CHECK:         %{{.*}} = fir.call @_QMpolymorphic_testPup_ret() {{.*}} : () -> !fir.class<!fir.ptr<!fir.array<?xnone>>>
 
-  subroutine rebox_f32_to_none(r)
+  subroutine associate_up_pointer(r)
     class(r1) :: r
     class(*), pointer :: p(:)
     p => r%rp
   end subroutine
 
-! CHECK-LABEL: func.func @_QMpolymorphic_testPrebox_f32_to_none(
+! CHECK-LABEL: func.func @_QMpolymorphic_testPassociate_up_pointer(
 ! CHECK-SAME: %[[ARG0:.*]]: !fir.class<!fir.type<_QMpolymorphic_testTr1{rp:!fir.box<!fir.ptr<!fir.array<?xf32>>>}>> {fir.bindc_name = "r"}) {
-! CHECK: %[[P:.*]] = fir.alloca !fir.class<!fir.ptr<!fir.array<?xnone>>> {bindc_name = "p", uniq_name = "_QMpolymorphic_testFrebox_f32_to_noneEp"}
+! CHECK: %[[P:.*]] = fir.alloca !fir.class<!fir.ptr<!fir.array<?xnone>>> {bindc_name = "p", uniq_name = "_QMpolymorphic_testFassociate_up_pointerEp"}
 ! CHECK: %[[FIELD_RP:.*]] = fir.field_index rp, !fir.type<_QMpolymorphic_testTr1{rp:!fir.box<!fir.ptr<!fir.array<?xf32>>>}>
 ! CHECK: %[[COORD_RP:.*]] = fir.coordinate_of %[[ARG0]], %[[FIELD_RP]] : (!fir.class<!fir.type<_QMpolymorphic_testTr1{rp:!fir.box<!fir.ptr<!fir.array<?xf32>>>}>>, !fir.field) -> !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>
-! CHECK: %[[LOADED_RP:.*]] = fir.load %[[COORD_RP]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>
-! CHECK: %[[C0:.*]] = arith.constant 0 : index
-! CHECK: %[[RP_DIMS:.*]]:3 = fir.box_dims %[[LOADED_RP]], %[[C0]] : (!fir.box<!fir.ptr<!fir.array<?xf32>>>, index) -> (index, index, index)
-! CHECK: %[[SHIFT:.*]] = fir.shift %[[RP_DIMS]]#0 : (index) -> !fir.shift<1>
-! CHECK: %[[REBOX_TO_BOX:.*]] = fir.rebox %[[LOADED_RP]](%[[SHIFT]]) : (!fir.box<!fir.ptr<!fir.array<?xf32>>>, !fir.shift<1>) -> !fir.box<!fir.array<?xf32>>
-! CHECK: %[[REBOX_TO_UP:.*]] = fir.rebox %[[REBOX_TO_BOX]] : (!fir.box<!fir.array<?xf32>>) -> !fir.class<!fir.ptr<!fir.array<?xnone>>>
-! CHECK: fir.store %[[REBOX_TO_UP]] to %[[P]] : !fir.ref<!fir.class<!fir.ptr<!fir.array<?xnone>>>>
+! CHECK: %[[CONV_P:.*]] = fir.convert %[[P]] : (!fir.ref<!fir.class<!fir.ptr<!fir.array<?xnone>>>>) -> !fir.ref<!fir.box<none>>
+! CHECK: %[[CONV_RP:.*]] = fir.convert %[[COORD_RP]] : (!fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>) -> !fir.box<none>
+! CHECK: %{{.*}} = fir.call @_FortranAPointerAssociate(%[[CONV_P]], %[[CONV_RP]]) {{.*}} : (!fir.ref<!fir.box<none>>, !fir.box<none>) -> none
 ! CHECK: return
 
 ! Test that the fir.dispatch operation is created with the correct pass object
 ! and the pass_arg_pos attribute is incremented correctly when character
 ! function result is added as argument.
 
   function get_tmp(this)
     class(c1) :: this