[flang-commits] [flang] 4bb1751 - [flang] Lowering and implementation for same_type_as
Valentin Clement via flang-commits
flang-commits at lists.llvm.org
Wed Jan 11 00:30:48 PST 2023
Author: Valentin Clement
Date: 2023-01-11T09:30:42+01:00
New Revision: 4bb1751140b99ce4a8bb7f88c1b631c535e52f1d
URL: https://github.com/llvm/llvm-project/commit/4bb1751140b99ce4a8bb7f88c1b631c535e52f1d
DIFF: https://github.com/llvm/llvm-project/commit/4bb1751140b99ce4a8bb7f88c1b631c535e52f1d.diff
LOG: [flang] Lowering and implementation for same_type_as
The test performed by same_type_as does not consider kind type
parameters. If an exact match is not found, the name of the
derived type is compared. The name in the runtime info does not include
the kind type parameters as it does in the mangled name.
Reviewed By: jeanPerier, PeteSteinfeld
Differential Revision: https://reviews.llvm.org/D141364
Added:
flang/test/Lower/Intrinsics/same_type_as.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 239eab1d4e418..076f7bda6171c 100644
--- a/flang/include/flang/Optimizer/Builder/Runtime/Derived.h
+++ b/flang/include/flang/Optimizer/Builder/Runtime/Derived.h
@@ -37,5 +37,8 @@ void genNullifyDerivedType(fir::FirOpBuilder &builder, mlir::Location loc,
mlir::Value box, fir::RecordType derivedType,
unsigned rank = 0);
+mlir::Value genSameTypeAs(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 5d08694dd58c7..1433f91b9f025 100644
--- a/flang/include/flang/Runtime/derived-api.h
+++ b/flang/include/flang/Runtime/derived-api.h
@@ -46,6 +46,9 @@ void RTNAME(Assign)(const Descriptor &, const Descriptor &,
// construct.
bool RTNAME(ClassIs)(const Descriptor &, const typeInfo::DerivedType &);
+// Perform the test of the SAME_TYPE_AS intrinsic.
+bool RTNAME(SameTypeAs)(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 1ee096f197c19..f8c601c829d41 100644
--- a/flang/lib/Lower/IntrinsicCall.cpp
+++ b/flang/lib/Lower/IntrinsicCall.cpp
@@ -25,6 +25,7 @@
#include "flang/Optimizer/Builder/MutableBox.h"
#include "flang/Optimizer/Builder/Runtime/Character.h"
#include "flang/Optimizer/Builder/Runtime/Command.h"
+#include "flang/Optimizer/Builder/Runtime/Derived.h"
#include "flang/Optimizer/Builder/Runtime/Inquiry.h"
#include "flang/Optimizer/Builder/Runtime/Numeric.h"
#include "flang/Optimizer/Builder/Runtime/RTBuilder.h"
@@ -564,6 +565,8 @@ struct IntrinsicLibrary {
fir::ExtendedValue genReshape(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
mlir::Value genRRSpacing(mlir::Type resultType,
llvm::ArrayRef<mlir::Value> args);
+ fir::ExtendedValue genSameTypeAs(mlir::Type,
+ llvm::ArrayRef<fir::ExtendedValue>);
mlir::Value genScale(mlir::Type, llvm::ArrayRef<mlir::Value>);
fir::ExtendedValue genScan(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
mlir::Value genSelectedIntKind(mlir::Type, llvm::ArrayRef<mlir::Value>);
@@ -1013,6 +1016,10 @@ static constexpr IntrinsicHandler handlers[]{
{"order", asBox, handleDynamicOptional}}},
/*isElemental=*/false},
{"rrspacing", &I::genRRSpacing},
+ {"same_type_as",
+ &I::genSameTypeAs,
+ {{{"a", asBox}, {"b", asBox}}},
+ /*isElemental=*/false},
{"scale",
&I::genScale,
{{{"x", asValue}, {"i", asValue}}},
@@ -4491,6 +4498,18 @@ mlir::Value IntrinsicLibrary::genRRSpacing(mlir::Type resultType,
fir::runtime::genRRSpacing(builder, loc, fir::getBase(args[0])));
}
+// SAME_TYPE_AS
+fir::ExtendedValue
+IntrinsicLibrary::genSameTypeAs(mlir::Type resultType,
+ llvm::ArrayRef<fir::ExtendedValue> args) {
+ assert(args.size() == 2);
+
+ return builder.createConvert(
+ loc, resultType,
+ fir::runtime::genSameTypeAs(builder, loc, fir::getBase(args[0]),
+ fir::getBase(args[1])));
+}
+
// SCALE
mlir::Value IntrinsicLibrary::genScale(mlir::Type resultType,
llvm::ArrayRef<mlir::Value> args) {
diff --git a/flang/lib/Optimizer/Builder/Runtime/Derived.cpp b/flang/lib/Optimizer/Builder/Runtime/Derived.cpp
index 8700c9ef1254b..b2840360ec662 100644
--- a/flang/lib/Optimizer/Builder/Runtime/Derived.cpp
+++ b/flang/lib/Optimizer/Builder/Runtime/Derived.cpp
@@ -62,3 +62,13 @@ void fir::runtime::genNullifyDerivedType(fir::FirOpBuilder &builder,
args.push_back(c0);
builder.create<fir::CallOp>(loc, callee, args);
}
+
+mlir::Value fir::runtime::genSameTypeAs(fir::FirOpBuilder &builder,
+ mlir::Location loc, mlir::Value a,
+ mlir::Value b) {
+ mlir::func::FuncOp sameTypeAsFunc =
+ fir::runtime::getRuntimeFunc<mkRTKey(SameTypeAs)>(loc, builder);
+ auto fTy = sameTypeAsFunc.getFunctionType();
+ auto args = fir::runtime::createArguments(builder, loc, fTy, a, b);
+ return builder.create<fir::CallOp>(loc, sameTypeAsFunc, args).getResult(0);
+}
diff --git a/flang/runtime/derived-api.cpp b/flang/runtime/derived-api.cpp
index 5817296b0b1a1..722ae11d6f461 100644
--- a/flang/runtime/derived-api.cpp
+++ b/flang/runtime/derived-api.cpp
@@ -58,6 +58,44 @@ bool RTNAME(ClassIs)(
return false;
}
+static bool CompareDerivedTypeNames(const Descriptor &a, const Descriptor &b) {
+ if (a.raw().version == CFI_VERSION &&
+ a.type() == TypeCode{TypeCategory::Character, 1} &&
+ a.ElementBytes() > 0 && a.rank() == 0 && a.OffsetElement() != nullptr &&
+ a.raw().version == CFI_VERSION &&
+ b.type() == TypeCode{TypeCategory::Character, 1} &&
+ b.ElementBytes() > 0 && b.rank() == 0 && b.OffsetElement() != nullptr &&
+ a.ElementBytes() == b.ElementBytes() &&
+ memcmp(a.OffsetElement(), b.OffsetElement(), a.ElementBytes()) == 0) {
+ return true;
+ }
+ return false;
+}
+
+static const typeInfo::DerivedType *GetDerivedType(const Descriptor &desc) {
+ if (const DescriptorAddendum * addendum{desc.Addendum()}) {
+ if (const auto *derived{addendum->derivedType()}) {
+ return derived;
+ }
+ }
+ return nullptr;
+}
+
+bool RTNAME(SameTypeAs)(const Descriptor &a, const Descriptor &b) {
+ const typeInfo::DerivedType *derivedTypeA{GetDerivedType(a)};
+ const typeInfo::DerivedType *derivedTypeB{GetDerivedType(b)};
+ if (derivedTypeA == nullptr || derivedTypeB == nullptr) {
+ return false;
+ }
+ // Exact match of derived type.
+ if (derivedTypeA == derivedTypeB) {
+ return true;
+ }
+ // Otherwise compare with the name. Note 16.29 kind type parameters are not
+ // considered in the test.
+ return CompareDerivedTypeNames(derivedTypeA->name(), derivedTypeB->name());
+}
+
// TODO: Assign()
} // extern "C"
diff --git a/flang/test/Lower/Intrinsics/same_type_as.f90 b/flang/test/Lower/Intrinsics/same_type_as.f90
new file mode 100644
index 0000000000000..d8d524a86bda7
--- /dev/null
+++ b/flang/test/Lower/Intrinsics/same_type_as.f90
@@ -0,0 +1,47 @@
+! RUN: bbc -emit-fir -polymorphic-type %s -o - | FileCheck %s
+
+module same_type_as_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_same_type(a, b)
+ class(*) :: a
+ class(*) :: b
+
+ if (same_type_as(a, b)) then
+ print*, 'same_type_as ok'
+ else
+ print*, 'same_type_as failed'
+ end if
+ end subroutine
+
+! CHECK-LABEL: func.func @_QMsame_type_as_modPis_same_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 @_FortranASameTypeAs(%[[BOX0]], %[[BOX1]]) {{.*}} : (!fir.box<none>, !fir.box<none>) -> i1
+
+end module
+
+program test
+ use same_type_as_mod
+ type(p1) :: p, r
+ type(p2) :: q
+ type(k1(10)) :: k10
+ type(k1(20)) :: k20
+
+ call is_same_type(p, q)
+ call is_same_type(p, r)
+ call is_same_type(k10, k20)
+end
More information about the flang-commits
mailing list