diff --git a/flang/include/flang/Lower/Runtime.h b/flang/include/flang/Lower/Runtime.h --- a/flang/include/flang/Lower/Runtime.h +++ b/flang/include/flang/Lower/Runtime.h @@ -69,6 +69,9 @@ 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 date, diff --git a/flang/include/flang/Optimizer/Dialect/FIRType.h b/flang/include/flang/Optimizer/Dialect/FIRType.h --- a/flang/include/flang/Optimizer/Dialect/FIRType.h +++ b/flang/include/flang/Optimizer/Dialect/FIRType.h @@ -280,6 +280,12 @@ /// e.g. !fir.box> bool isBoxedRecordType(mlir::Type ty); +/// Return true iff `ty` is a !fir.ref> type. +bool isRefBoxType(mlir::Type ty); + +/// Return true iff `ty` is !fir.box type. +bool isOpaqueDescType(mlir::Type ty); + /// Return true iff `ty` is the type of an polymorphic entity or /// value. bool isPolymorphicType(mlir::Type ty); diff --git a/flang/lib/Lower/Bridge.cpp b/flang/lib/Lower/Bridge.cpp --- a/flang/lib/Lower/Bridge.cpp +++ b/flang/lib/Lower/Bridge.cpp @@ -2710,6 +2710,19 @@ [&](const Fortran::evaluate::Assignment::BoundsSpec &lbExprs) { if (Fortran::evaluate::IsProcedure(assign.rhs)) TODO(loc, "procedure pointer assignment"); + + std::optional 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 lbounds; for (const Fortran::evaluate::ExtentExpr &lbExpr : lbExprs) lbounds.push_back( diff --git a/flang/lib/Lower/Runtime.cpp b/flang/lib/Lower/Runtime.cpp --- a/flang/lib/Lower/Runtime.cpp +++ b/flang/lib/Lower/Runtime.cpp @@ -188,6 +188,17 @@ return builder.create(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(loc, builder); + llvm::SmallVector args = fir::runtime::createArguments( + builder, loc, func.getFunctionType(), pointer, target); + builder.create(loc, func, args).getResult(0); +} + mlir::Value Fortran::lower::genCpuTime(fir::FirOpBuilder &builder, mlir::Location loc) { mlir::func::FuncOp func = diff --git a/flang/lib/Optimizer/Dialect/FIROps.cpp b/flang/lib/Optimizer/Dialect/FIROps.cpp --- a/flang/lib/Optimizer/Dialect/FIROps.cpp +++ b/flang/lib/Optimizer/Dialect/FIROps.cpp @@ -938,8 +938,10 @@ (inType.isa() && outType.isa()) || (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"); } diff --git a/flang/lib/Optimizer/Dialect/FIRType.cpp b/flang/lib/Optimizer/Dialect/FIRType.cpp --- a/flang/lib/Optimizer/Dialect/FIRType.cpp +++ b/flang/lib/Optimizer/Dialect/FIRType.cpp @@ -274,6 +274,19 @@ return false; } +bool isRefBoxType(mlir::Type ty) { + if (auto refTy = ty.dyn_cast()) + return refTy.getEleTy().isa(); + return false; +} + +bool isOpaqueDescType(mlir::Type ty) { + if (auto boxTy = ty.dyn_cast()) + if (boxTy.getEleTy().isa()) + return true; + return false; +} + static bool isAssumedType(mlir::Type ty) { if (auto boxTy = ty.dyn_cast()) { if (boxTy.getEleTy().isa()) diff --git a/flang/test/Lower/polymorphic.f90 b/flang/test/Lower/polymorphic.f90 --- a/flang/test/Lower/polymorphic.f90 +++ b/flang/test/Lower/polymorphic.f90 @@ -130,24 +130,20 @@ ! CHECK-LABEL: func.func @_QMpolymorphic_testPcall_up_ret() { ! CHECK: %{{.*}} = fir.call @_QMpolymorphic_testPup_ret() {{.*}} : () -> !fir.class>> - 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.bindc_name = "r"}) { -! CHECK: %[[P:.*]] = fir.alloca !fir.class>> {bindc_name = "p", uniq_name = "_QMpolymorphic_testFrebox_f32_to_noneEp"} +! CHECK: %[[P:.*]] = fir.alloca !fir.class>> {bindc_name = "p", uniq_name = "_QMpolymorphic_testFassociate_up_pointerEp"} ! CHECK: %[[FIELD_RP:.*]] = fir.field_index rp, !fir.type<_QMpolymorphic_testTr1{rp:!fir.box>>}> ! CHECK: %[[COORD_RP:.*]] = fir.coordinate_of %[[ARG0]], %[[FIELD_RP]] : (!fir.class>>}>>, !fir.field) -> !fir.ref>>> -! CHECK: %[[LOADED_RP:.*]] = fir.load %[[COORD_RP]] : !fir.ref>>> -! CHECK: %[[C0:.*]] = arith.constant 0 : index -! CHECK: %[[RP_DIMS:.*]]:3 = fir.box_dims %[[LOADED_RP]], %[[C0]] : (!fir.box>>, 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.shift<1>) -> !fir.box> -! CHECK: %[[REBOX_TO_UP:.*]] = fir.rebox %[[REBOX_TO_BOX]] : (!fir.box>) -> !fir.class>> -! CHECK: fir.store %[[REBOX_TO_UP]] to %[[P]] : !fir.ref>>> +! CHECK: %[[CONV_P:.*]] = fir.convert %[[P]] : (!fir.ref>>>) -> !fir.ref> +! CHECK: %[[CONV_RP:.*]] = fir.convert %[[COORD_RP]] : (!fir.ref>>>) -> !fir.box +! CHECK: %{{.*}} = fir.call @_FortranAPointerAssociate(%[[CONV_P]], %[[CONV_RP]]) {{.*}} : (!fir.ref>, !fir.box) -> none ! CHECK: return ! Test that the fir.dispatch operation is created with the correct pass object