diff --git a/flang/include/flang/Optimizer/Builder/MutableBox.h b/flang/include/flang/Optimizer/Builder/MutableBox.h --- a/flang/include/flang/Optimizer/Builder/MutableBox.h +++ b/flang/include/flang/Optimizer/Builder/MutableBox.h @@ -38,9 +38,12 @@ /// \p nonDeferredParams must provide the non deferred LEN parameters so that /// they can already be placed in the unallocated box (inquiries about these /// parameters are legal even in unallocated state). +/// \p typeSourceBox provides the dynamic type information when the box is +/// created for a polymorphic temporary. mlir::Value createUnallocatedBox(fir::FirOpBuilder &builder, mlir::Location loc, mlir::Type boxType, - mlir::ValueRange nonDeferredParams); + mlir::ValueRange nonDeferredParams, + mlir::Value typeSourceBox = {}); /// Create a MutableBoxValue for a temporary allocatable. /// The created MutableBoxValue wraps a fir.ref>> and is @@ -48,7 +51,8 @@ /// given to the created !fir.ref. fir::MutableBoxValue createTempMutableBox(fir::FirOpBuilder &builder, mlir::Location loc, mlir::Type type, - llvm::StringRef name = {}); + llvm::StringRef name = {}, + mlir::Value sourceBox = {}); /// Update a MutableBoxValue to describe entity \p source (that must be in /// memory). If \lbounds is not empty, it is used to defined the MutableBoxValue diff --git a/flang/lib/Lower/IntrinsicCall.cpp b/flang/lib/Lower/IntrinsicCall.cpp --- a/flang/lib/Lower/IntrinsicCall.cpp +++ b/flang/lib/Lower/IntrinsicCall.cpp @@ -4733,8 +4733,9 @@ // Generate result descriptor mlir::Type resultArrayType = builder.getVarLenSeqTy(resultType, sourceRank + 1); - fir::MutableBoxValue resultMutableBox = - fir::factory::createTempMutableBox(builder, loc, resultArrayType); + fir::MutableBoxValue resultMutableBox = fir::factory::createTempMutableBox( + builder, loc, resultArrayType, {}, + fir::isPolymorphicType(source.getType()) ? source : mlir::Value{}); mlir::Value resultIrBox = fir::factory::getMutableIRBox(builder, loc, resultMutableBox); diff --git a/flang/lib/Optimizer/Builder/MutableBox.cpp b/flang/lib/Optimizer/Builder/MutableBox.cpp --- a/flang/lib/Optimizer/Builder/MutableBox.cpp +++ b/flang/lib/Optimizer/Builder/MutableBox.cpp @@ -190,8 +190,9 @@ class MutablePropertyWriter { public: MutablePropertyWriter(fir::FirOpBuilder &builder, mlir::Location loc, - const fir::MutableBoxValue &box) - : builder{builder}, loc{loc}, box{box} {} + const fir::MutableBoxValue &box, + mlir::Value typeSourceBox = {}) + : builder{builder}, loc{loc}, box{box}, typeSourceBox{typeSourceBox} {} /// Update MutableBoxValue with new address, shape and length parameters. /// Extents and lbounds must all have index type. /// lbounds can be empty in which case all ones is assumed. @@ -232,7 +233,8 @@ // this is just like NULLIFY and the dynamic type must be set to the // declared type, not retain the previous dynamic type. auto deallocatedBox = fir::factory::createUnallocatedBox( - builder, loc, box.getBoxTy(), box.nonDeferredLenParams()); + builder, loc, box.getBoxTy(), box.nonDeferredLenParams(), + typeSourceBox); builder.create(loc, deallocatedBox, box.getAddr()); } } @@ -311,14 +313,14 @@ fir::FirOpBuilder &builder; mlir::Location loc; fir::MutableBoxValue box; + mlir::Value typeSourceBox; }; } // namespace -mlir::Value -fir::factory::createUnallocatedBox(fir::FirOpBuilder &builder, - mlir::Location loc, mlir::Type boxType, - mlir::ValueRange nonDeferredParams) { +mlir::Value fir::factory::createUnallocatedBox( + fir::FirOpBuilder &builder, mlir::Location loc, mlir::Type boxType, + mlir::ValueRange nonDeferredParams, mlir::Value typeSourceBox) { auto baseAddrType = boxType.dyn_cast().getEleTy(); if (!fir::isa_ref_type(baseAddrType)) baseAddrType = builder.getRefType(baseAddrType); @@ -352,19 +354,23 @@ } mlir::Value emptySlice; return builder.create(loc, boxType, nullAddr, shape, emptySlice, - lenParams); + lenParams, typeSourceBox); } -fir::MutableBoxValue -fir::factory::createTempMutableBox(fir::FirOpBuilder &builder, - mlir::Location loc, mlir::Type type, - llvm::StringRef name) { - auto boxType = fir::BoxType::get(fir::HeapType::get(type)); +fir::MutableBoxValue fir::factory::createTempMutableBox( + fir::FirOpBuilder &builder, mlir::Location loc, mlir::Type type, + llvm::StringRef name, mlir::Value typeSourceBox) { + mlir::Type boxType; + if (typeSourceBox) + boxType = fir::ClassType::get(fir::HeapType::get(type)); + else + boxType = fir::BoxType::get(fir::HeapType::get(type)); auto boxAddr = builder.createTemporary(loc, boxType, name); auto box = fir::MutableBoxValue(boxAddr, /*nonDeferredParams=*/mlir::ValueRange(), /*mutableProperties=*/{}); - MutablePropertyWriter{builder, loc, box}.setUnallocatedStatus(); + MutablePropertyWriter{builder, loc, box, typeSourceBox} + .setUnallocatedStatus(); return box; } diff --git a/flang/lib/Optimizer/CodeGen/CodeGen.cpp b/flang/lib/Optimizer/CodeGen/CodeGen.cpp --- a/flang/lib/Optimizer/CodeGen/CodeGen.cpp +++ b/flang/lib/Optimizer/CodeGen/CodeGen.cpp @@ -1585,13 +1585,11 @@ loc, rewriter, useInputType ? inputType : boxTy.getEleTy(), typeparams); mlir::Value typeDesc; - if (sourceBox) + // When emboxing to a polymorphic box, get the type descriptor, type code + // and element size from the source box if any. + if (fir::isPolymorphicType(boxTy) && sourceBox) { typeDesc = this->loadTypeDescAddress(loc, sourceBoxType, sourceBox, rewriter); - // When emboxing a fir.ref to an unlimited polymorphic box, get the - // type code and element size from the box used to extract the type desc. - if (fir::isUnlimitedPolymorphicType(boxTy) && - inputType.isa() && sourceBox) { mlir::Type idxTy = this->lowerTy().indexType(); eleSize = this->getElementSizeFromBox(loc, idxTy, sourceBox, rewriter); cfiTy = this->getValueFromBox(loc, sourceBox, cfiTy.getType(), rewriter, diff --git a/flang/test/Lower/allocatable-polymorphic.f90 b/flang/test/Lower/allocatable-polymorphic.f90 --- a/flang/test/Lower/allocatable-polymorphic.f90 +++ b/flang/test/Lower/allocatable-polymorphic.f90 @@ -490,19 +490,40 @@ ! LLVM: %[[GEP_TDESC_C3:.*]] = getelementptr { ptr, i64, i32, i8, i8, i8, i8, [1 x [3 x i64]], ptr, [1 x i64] }, ptr %{{.*}}, i32 0, i32 8 ! LLVM: %[[TDESC_C3:.*]] = load ptr, ptr %[[GEP_TDESC_C3]] - -! LLVM: %[[BOX0:.*]] = insertvalue { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] } { ptr undef, i64 ptrtoint (ptr getelementptr (%_QMpolyTp1, ptr null, i32 1) to i64), i32 20180515, i8 0, i8 42, i8 0, i8 1, ptr undef, [1 x i64] undef }, ptr %[[TDESC_C3]], 7 -! LLVM: %[[BOX1:.*]] = insertvalue { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] } %[[BOX0]], ptr %{{.*}}, 0 -! LLVM: store { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] } %[[BOX1]], ptr %{{.*}} +! LLVM: %[[ELE_SIZE_GEP:.*]] = getelementptr { ptr, i64, i32, i8, i8, i8, i8, [1 x [3 x i64]], ptr, [1 x i64] }, ptr %{{.*}}, i32 0, i32 1 +! LLVM: %[[ELE_SIZE:.*]] = load i64, ptr %[[ELE_SIZE_GEP]] +! LLVM: %[[TYPE_CODE_GEP:.*]] = getelementptr { ptr, i64, i32, i8, i8, i8, i8, [1 x [3 x i64]], ptr, [1 x i64] }, ptr %{{.*}}, i32 0, i32 4 +! LLVM: %[[TYPE_CODE:.*]] = load i32, ptr %[[TYPE_CODE_GEP]] +! LLVM: %[[BOX0:.*]] = insertvalue { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] } undef, i64 %[[ELE_SIZE]], 1 +! LLVM: %[[BOX1:.*]] = insertvalue { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] } %[[BOX0]], i32 20180515, 2 +! LLVM: %[[BOX2:.*]] = insertvalue { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] } %[[BOX1]], i8 0, 3 +! LLVM: %[[TYPE_CODE_TRUNC:.*]] = trunc i32 %[[TYPE_CODE]] to i8 +! LLVM: %[[BOX3:.*]] = insertvalue { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] } %[[BOX2]], i8 %[[TYPE_CODE_TRUNC]], 4 +! LLVM: %[[BOX4:.*]] = insertvalue { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] } %[[BOX3]], i8 0, 5 +! LLVM: %[[BOX5:.*]] = insertvalue { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] } %[[BOX4]], i8 1, 6 +! LLVM: %[[BOX6:.*]] = insertvalue { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] } %[[BOX5]], ptr %[[TDESC_C3]], 7 +! LLVM: %[[BOX7:.*]] = insertvalue { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] } %[[BOX6]], ptr %{{.*}}, 0 +! LLVM: store { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] } %[[BOX7]], ptr %{{.*}} ! LLVM: call void %{{.*}}(ptr %{{.*}}) ! LLVM: %[[C4_LOAD:.*]] = load { ptr, i64, i32, i8, i8, i8, i8, [1 x [3 x i64]], ptr, [1 x i64] }, ptr %{{.*}} ! LLVM: store { ptr, i64, i32, i8, i8, i8, i8, [1 x [3 x i64]], ptr, [1 x i64] } %[[C4_LOAD]], ptr %{{.*}} ! LLVM: %[[GEP_TDESC_C4:.*]] = getelementptr { ptr, i64, i32, i8, i8, i8, i8, [1 x [3 x i64]], ptr, [1 x i64] }, ptr %{{.*}}, i32 0, i32 8 ! LLVM: %[[TDESC_C4:.*]] = load ptr, ptr %[[GEP_TDESC_C4]] -! LLVM: %[[BOX0:.*]] = insertvalue { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] } { ptr undef, i64 ptrtoint (ptr getelementptr (%_QMpolyTp1, ptr null, i32 1) to i64), i32 20180515, i8 0, i8 42, i8 0, i8 1, ptr undef, [1 x i64] undef }, ptr %[[TDESC_C4]], 7 -! LLVM: %[[BOX1:.*]] = insertvalue { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] } %[[BOX0]], ptr %{{.*}}, 0 -! LLVM: store { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] } %[[BOX1]], ptr %{{.*}} +! LLVM: %[[ELE_SIZE_GEP:.*]] = getelementptr { ptr, i64, i32, i8, i8, i8, i8, [1 x [3 x i64]], ptr, [1 x i64] }, ptr %{{.*}}, i32 0, i32 1 +! LLVM: %[[ELE_SIZE:.*]] = load i64, ptr %[[ELE_SIZE_GEP]] +! LLVM: %[[TYPE_CODE_GEP:.*]] = getelementptr { ptr, i64, i32, i8, i8, i8, i8, [1 x [3 x i64]], ptr, [1 x i64] }, ptr %{{.*}}, i32 0, i32 4 +! LLVM: %[[TYPE_CODE:.*]] = load i32, ptr %[[TYPE_CODE_GEP]] +! LLVM: %[[BOX0:.*]] = insertvalue { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] } undef, i64 %[[ELE_SIZE]], 1 +! LLVM: %[[BOX1:.*]] = insertvalue { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] } %[[BOX0]], i32 20180515, 2 +! LLVM: %[[BOX2:.*]] = insertvalue { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] } %[[BOX1]], i8 0, 3 +! LLVM: %[[TYPE_CODE_TRUNC:.*]] = trunc i32 %[[TYPE_CODE]] to i8 +! LLVM: %[[BOX3:.*]] = insertvalue { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] } %[[BOX2]], i8 %[[TYPE_CODE_TRUNC]], 4 +! LLVM: %[[BOX4:.*]] = insertvalue { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] } %[[BOX3]], i8 0, 5 +! LLVM: %[[BOX5:.*]] = insertvalue { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] } %[[BOX4]], i8 1, 6 +! LLVM: %[[BOX6:.*]] = insertvalue { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] } %[[BOX5]], ptr %[[TDESC_C4]], 7 +! LLVM: %[[BOX7:.*]] = insertvalue { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] } %[[BOX6]], ptr %{{.*}}, 0 +! LLVM: store { ptr, i64, i32, i8, i8, i8, i8, ptr, [1 x i64] } %[[BOX7]], ptr %{{.*}} ! LLVM: call void %{{.*}}(ptr %{{.*}}) diff --git a/flang/test/Lower/polymorphic-temp.f90 b/flang/test/Lower/polymorphic-temp.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Lower/polymorphic-temp.f90 @@ -0,0 +1,50 @@ +! Test creation of temporary from polymorphic enities +! RUN: bbc -polymorphic-type -emit-fir %s -o - | FileCheck %s + +module poly_tmp + type p1 + integer :: a + end type + + type, extends(p1) :: p2 + integer :: b + end type + +contains + subroutine pass_unlimited_poly_1d(x) + class(*), intent(in) :: x(:) + end subroutine + + + subroutine test_temp_from_intrinsic_spread() + class(*), pointer :: p + allocate(p2::p) + + call pass_unlimited_poly_1d(spread(p, dim=1, ncopies=2)) + end subroutine + +! CHECK-LABEL: func.func @_QMpoly_tmpPtest_temp_from_intrinsic_spread() { +! CHECK: %[[TEMP_RES:.*]] = fir.alloca !fir.class>> +! CHECK: %[[P:.*]] = fir.alloca !fir.class> {bindc_name = "p", uniq_name = "_QMpoly_tmpFtest_temp_from_intrinsic_spreadEp"} +! CHECK: fir.call @_FortranAPointerNullifyDerived +! CHECK: fir.call @_FortranAPointerAllocate +! CHECK: %[[LOAD_P:.*]] = fir.load %[[P]] : !fir.ref>> +! CHECK: %[[C1:.*]] = arith.constant 1 : i32 +! CHECK: %[[C2:.*]] = arith.constant 2 : i32 +! CHECK: %[[ZERO:.*]] = fir.zero_bits !fir.heap> +! CHECK: %[[C0:.*]] = arith.constant 0 : index +! CHECK: %[[SHAPE:.*]] = fir.shape %[[C0]] : (index) -> !fir.shape<1> +! Make sure the fir.embox contains the source_box pointing to the polymoprhic entity +! CHECK: %[[BOX_RES:.*]] = fir.embox %[[ZERO]](%[[SHAPE]]) source_box %[[LOAD_P]] : (!fir.heap>, !fir.shape<1>, !fir.class>) -> !fir.class>> +! CHECK: fir.store %[[BOX_RES]] to %[[TEMP_RES]] : !fir.ref>>> +! CHECK: %[[RES_BOX_NONE:.*]] = fir.convert %[[TEMP_RES]] : (!fir.ref>>>) -> !fir.ref> +! CHECK: %[[P_BOX_NONE:.*]] = fir.convert %[[LOAD_P]] : (!fir.class>) -> !fir.box +! CHECK: %[[C2_I64:.*]] = fir.convert %[[C2]] : (i32) -> i64 +! CHECK: %{{.*}} = fir.call @_FortranASpread(%[[RES_BOX_NONE]], %[[P_BOX_NONE]], %[[C1]], %[[C2_I64]], %{{.*}}, %{{.*}}) fastmath : (!fir.ref>, !fir.box, i32, i64, !fir.ref, i32) -> none +! CHECK: %[[LOAD_RES:.*]] = fir.load %[[TEMP_RES]] : !fir.ref>>> +! CHECK: %[[RES_ADDR:.*]] = fir.box_addr %[[LOAD_RES]] : (!fir.class>>) -> !fir.heap> +! CHECK: %[[REBOX:.*]] = fir.rebox %[[LOAD_RES]] : (!fir.class>>) -> !fir.class> +! CHECK: fir.call @_QMpoly_tmpPpass_unlimited_poly_1d(%[[REBOX]]) {{.*}} : (!fir.class>) -> () +! CHECK: fir.freemem %[[RES_ADDR]] : !fir.heap> + +end module