[flang-commits] [flang] 87bd946 - [flang] Lowering and implementation for extends_type_of
Valentin Clement via flang-commits
flang-commits at lists.llvm.org
Wed Jan 11 00:32:28 PST 2023
Author: Valentin Clement
Date: 2023-01-11T09:32:22+01:00
New Revision: 87bd946138483068ab30ff8a19d4ec344de42f57
URL: https://github.com/llvm/llvm-project/commit/87bd946138483068ab30ff8a19d4ec344de42f57
DIFF: https://github.com/llvm/llvm-project/commit/87bd946138483068ab30ff8a19d4ec344de42f57.diff
LOG: [flang] Lowering and implementation for extends_type_of
Add implementation and loweirng for the extends_type_of
intrinsic.
The standard mentions this: otherwise if the dynamic type of A or MOLD is
extensible, the result is true if and only if the dynamic type of A is an
extension type of the dynamic type of MOLD. Which could be interpreted that
`extends_type_of(a, a)` could be false since a type is not an extension of
itself. Gfortran result for this is `true` so the same behavior is applied
here as well.
Depends on D141364
Reviewed By: jeanPerier, PeteSteinfeld
Differential Revision: https://reviews.llvm.org/D141376
Added:
flang/test/Lower/Intrinsics/extends_type_of.f90
Modified:
flang/include/flang/Optimizer/Builder/Runtime/Derived.h
flang/include/flang/Runtime/derived-api.h
flang/lib/Lower/IntrinsicCall.cpp
flang/lib/Optimizer/Builder/Runtime/Derived.cpp
flang/runtime/derived-api.cpp
Removed:
################################################################################
diff --git a/flang/include/flang/Optimizer/Builder/Runtime/Derived.h b/flang/include/flang/Optimizer/Builder/Runtime/Derived.h
index 076f7bda6171c..8539d2781c33b 100644
--- a/flang/include/flang/Optimizer/Builder/Runtime/Derived.h
+++ b/flang/include/flang/Optimizer/Builder/Runtime/Derived.h
@@ -40,5 +40,8 @@ void genNullifyDerivedType(fir::FirOpBuilder &builder, mlir::Location loc,
mlir::Value genSameTypeAs(fir::FirOpBuilder &builder, mlir::Location loc,
mlir::Value a, mlir::Value b);
+mlir::Value genExtendsTypeOf(fir::FirOpBuilder &builder, mlir::Location loc,
+ mlir::Value a, mlir::Value b);
+
} // namespace fir::runtime
#endif // FORTRAN_OPTIMIZER_BUILDER_RUNTIME_DERIVED_H
diff --git a/flang/include/flang/Runtime/derived-api.h b/flang/include/flang/Runtime/derived-api.h
index 1433f91b9f025..651ab406939e6 100644
--- a/flang/include/flang/Runtime/derived-api.h
+++ b/flang/include/flang/Runtime/derived-api.h
@@ -49,6 +49,9 @@ bool RTNAME(ClassIs)(const Descriptor &, const typeInfo::DerivedType &);
// Perform the test of the SAME_TYPE_AS intrinsic.
bool RTNAME(SameTypeAs)(const Descriptor &, const Descriptor &);
+// Perform the test of the EXTENDS_TYPE_OF intrinsic.
+bool RTNAME(ExtendsTypeOf)(const Descriptor &, const Descriptor &);
+
} // extern "C"
} // namespace Fortran::runtime
#endif // FORTRAN_RUNTIME_DERIVED_API_H_
diff --git a/flang/lib/Lower/IntrinsicCall.cpp b/flang/lib/Lower/IntrinsicCall.cpp
index f8c601c829d41..4258ad73f0df8 100644
--- a/flang/lib/Lower/IntrinsicCall.cpp
+++ b/flang/lib/Lower/IntrinsicCall.cpp
@@ -501,6 +501,8 @@ struct IntrinsicLibrary {
fir::ExtendedValue genEoshift(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
void genExit(llvm::ArrayRef<fir::ExtendedValue>);
mlir::Value genExponent(mlir::Type, llvm::ArrayRef<mlir::Value>);
+ fir::ExtendedValue genExtendsTypeOf(mlir::Type,
+ llvm::ArrayRef<fir::ExtendedValue>);
template <Extremum, ExtremumBehavior>
mlir::Value genExtremum(mlir::Type, llvm::ArrayRef<mlir::Value>);
mlir::Value genFloor(mlir::Type, llvm::ArrayRef<mlir::Value>);
@@ -815,6 +817,10 @@ static constexpr IntrinsicHandler handlers[]{
{{{"status", asValue, handleDynamicOptional}}},
/*isElemental=*/false},
{"exponent", &I::genExponent},
+ {"extends_type_of",
+ &I::genExtendsTypeOf,
+ {{{"a", asBox}, {"mold", asBox}}},
+ /*isElemental=*/false},
{"findloc",
&I::genFindloc,
{{{"array", asBox},
@@ -3292,6 +3298,18 @@ mlir::Value IntrinsicLibrary::genExponent(mlir::Type resultType,
fir::getBase(args[0])));
}
+// EXTENDS_TYPE_OF
+fir::ExtendedValue
+IntrinsicLibrary::genExtendsTypeOf(mlir::Type resultType,
+ llvm::ArrayRef<fir::ExtendedValue> args) {
+ assert(args.size() == 2);
+
+ return builder.createConvert(
+ loc, resultType,
+ fir::runtime::genExtendsTypeOf(builder, loc, fir::getBase(args[0]),
+ fir::getBase(args[1])));
+}
+
// FINDLOC
fir::ExtendedValue
IntrinsicLibrary::genFindloc(mlir::Type resultType,
diff --git a/flang/lib/Optimizer/Builder/Runtime/Derived.cpp b/flang/lib/Optimizer/Builder/Runtime/Derived.cpp
index b2840360ec662..796f35631bbee 100644
--- a/flang/lib/Optimizer/Builder/Runtime/Derived.cpp
+++ b/flang/lib/Optimizer/Builder/Runtime/Derived.cpp
@@ -72,3 +72,13 @@ mlir::Value fir::runtime::genSameTypeAs(fir::FirOpBuilder &builder,
auto args = fir::runtime::createArguments(builder, loc, fTy, a, b);
return builder.create<fir::CallOp>(loc, sameTypeAsFunc, args).getResult(0);
}
+
+mlir::Value fir::runtime::genExtendsTypeOf(fir::FirOpBuilder &builder,
+ mlir::Location loc, mlir::Value a,
+ mlir::Value mold) {
+ mlir::func::FuncOp extendsTypeOfFunc =
+ fir::runtime::getRuntimeFunc<mkRTKey(ExtendsTypeOf)>(loc, builder);
+ auto fTy = extendsTypeOfFunc.getFunctionType();
+ auto args = fir::runtime::createArguments(builder, loc, fTy, a, mold);
+ return builder.create<fir::CallOp>(loc, extendsTypeOfFunc, args).getResult(0);
+}
diff --git a/flang/runtime/derived-api.cpp b/flang/runtime/derived-api.cpp
index 722ae11d6f461..4eb9a09be07c4 100644
--- a/flang/runtime/derived-api.cpp
+++ b/flang/runtime/derived-api.cpp
@@ -72,6 +72,11 @@ static bool CompareDerivedTypeNames(const Descriptor &a, const Descriptor &b) {
return false;
}
+inline bool CompareDerivedType(
+ const typeInfo::DerivedType *a, const typeInfo::DerivedType *b) {
+ return a == b || CompareDerivedTypeNames(a->name(), b->name());
+}
+
static const typeInfo::DerivedType *GetDerivedType(const Descriptor &desc) {
if (const DescriptorAddendum * addendum{desc.Addendum()}) {
if (const auto *derived{addendum->derivedType()}) {
@@ -96,6 +101,49 @@ bool RTNAME(SameTypeAs)(const Descriptor &a, const Descriptor &b) {
return CompareDerivedTypeNames(derivedTypeA->name(), derivedTypeB->name());
}
+bool RTNAME(ExtendsTypeOf)(const Descriptor &a, const Descriptor &mold) {
+ const typeInfo::DerivedType *derivedTypeA{GetDerivedType(a)};
+ const typeInfo::DerivedType *derivedTypeMold{GetDerivedType(mold)};
+
+ // If MOLD is unlimited polymorphic and is either a disassociated pointer or
+ // unallocated allocatable, the result is true.
+ // Unlimited polymorphic descriptors are initialized with a CFI_type_other
+ // type.
+ if (mold.type().raw() == CFI_type_other &&
+ (mold.IsAllocatable() || mold.IsPointer()) &&
+ derivedTypeMold == nullptr) {
+ return true;
+ }
+
+ // If A is unlimited polymorphic and is either a disassociated pointer or
+ // unallocated allocatable, the result is false.
+ // Unlimited polymorphic descriptors are initialized with a CFI_type_other
+ // type.
+ if (a.type().raw() == CFI_type_other &&
+ (a.IsAllocatable() || a.IsPointer()) && derivedTypeA == nullptr) {
+ return false;
+ }
+
+ if (derivedTypeA == nullptr || derivedTypeMold == nullptr) {
+ return false;
+ }
+
+ // Otherwise if the dynamic type of A or MOLD is extensible, the result is
+ // true if and only if the dynamic type of A is an extension type of the
+ // dynamic type of MOLD.
+ if (CompareDerivedType(derivedTypeA, derivedTypeMold)) {
+ return true;
+ }
+ const typeInfo::DerivedType *parent{derivedTypeA->GetParentType()};
+ while (parent) {
+ if (CompareDerivedType(parent, derivedTypeMold)) {
+ return true;
+ }
+ parent = parent->GetParentType();
+ }
+ return false;
+}
+
// TODO: Assign()
} // extern "C"
diff --git a/flang/test/Lower/Intrinsics/extends_type_of.f90 b/flang/test/Lower/Intrinsics/extends_type_of.f90
new file mode 100644
index 0000000000000..642532f56bf6c
--- /dev/null
+++ b/flang/test/Lower/Intrinsics/extends_type_of.f90
@@ -0,0 +1,49 @@
+! RUN: bbc -emit-fir -polymorphic-type %s -o - | FileCheck %s
+
+module extends_type_of_mod
+
+ type p1
+ integer :: a
+ end type
+
+ type, extends(p1) :: p2
+ integer :: b
+ end type
+
+ type k1(a)
+ integer, kind :: a
+ end type
+
+contains
+ subroutine is_extended_type(a, b)
+ class(*) :: a
+ class(*) :: b
+
+ if (extends_type_of(a, b)) then
+ print*, 'extends_type_of ok'
+ else
+ print*, 'extends_type_of failed'
+ end if
+ end subroutine
+
+! CHECK-LABEL: func.func @_QMextends_type_of_modPis_extended_type(
+! CHECK-SAME: %[[ARG0:.*]]: !fir.class<none> {fir.bindc_name = "a"}, %[[ARG1:.*]]: !fir.class<none> {fir.bindc_name = "b"}) {
+! CHECK: %[[BOX0:.*]] = fir.convert %[[ARG0]] : (!fir.class<none>) -> !fir.box<none>
+! CHECK: %[[BOX1:.*]] = fir.convert %[[ARG1]] : (!fir.class<none>) -> !fir.box<none>
+! CHECK: %{{.*}} = fir.call @_FortranAExtendsTypeOf(%[[BOX0]], %[[BOX1]]) {{.*}} : (!fir.box<none>, !fir.box<none>) -> i1
+
+end module
+
+program test
+ use extends_type_of_mod
+ type(p1) :: p, r
+ type(p2) :: q
+ type(k1(10)) :: k10
+ type(k1(20)) :: k20
+
+ call is_extended_type(p, p)
+ call is_extended_type(p, q)
+ call is_extended_type(p, r)
+ call is_extended_type(q, p)
+ call is_extended_type(k10, k20)
+end
More information about the flang-commits
mailing list