From 4bb1751140b99ce4a8bb7f88c1b631c535e52f1d Mon Sep 17 00:00:00 2001 From: Valentin Clement Date: Wed, 11 Jan 2023 09:30:14 +0100 Subject: [PATCH] [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 --- .../flang/Optimizer/Builder/Runtime/Derived.h | 3 ++ flang/include/flang/Runtime/derived-api.h | 3 ++ flang/lib/Lower/IntrinsicCall.cpp | 19 +++++++++ flang/lib/Optimizer/Builder/Runtime/Derived.cpp | 10 +++++ flang/runtime/derived-api.cpp | 38 +++++++++++++++++ flang/test/Lower/Intrinsics/same_type_as.f90 | 47 ++++++++++++++++++++++ 6 files changed, 120 insertions(+) create mode 100644 flang/test/Lower/Intrinsics/same_type_as.f90 diff --git a/flang/include/flang/Optimizer/Builder/Runtime/Derived.h b/flang/include/flang/Optimizer/Builder/Runtime/Derived.h index 239eab1..076f7bd 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 5d08694..1433f91 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 1ee096f..f8c601c 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); mlir::Value genRRSpacing(mlir::Type resultType, llvm::ArrayRef args); + fir::ExtendedValue genSameTypeAs(mlir::Type, + llvm::ArrayRef); mlir::Value genScale(mlir::Type, llvm::ArrayRef); fir::ExtendedValue genScan(mlir::Type, llvm::ArrayRef); mlir::Value genSelectedIntKind(mlir::Type, llvm::ArrayRef); @@ -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 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 args) { diff --git a/flang/lib/Optimizer/Builder/Runtime/Derived.cpp b/flang/lib/Optimizer/Builder/Runtime/Derived.cpp index 8700c9e..b284036 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(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(loc, builder); + auto fTy = sameTypeAsFunc.getFunctionType(); + auto args = fir::runtime::createArguments(builder, loc, fTy, a, b); + return builder.create(loc, sameTypeAsFunc, args).getResult(0); +} diff --git a/flang/runtime/derived-api.cpp b/flang/runtime/derived-api.cpp index 5817296..722ae11 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 0000000..d8d524a --- /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 {fir.bindc_name = "a"}, %[[ARG1:.*]]: !fir.class {fir.bindc_name = "b"}) { +! CHECK: %[[BOX0:.*]] = fir.convert %[[ARG0]] : (!fir.class) -> !fir.box +! CHECK: %[[BOX1:.*]] = fir.convert %[[ARG1]] : (!fir.class) -> !fir.box +! CHECK: %{{.*}} = fir.call @_FortranASameTypeAs(%[[BOX0]], %[[BOX1]]) {{.*}} : (!fir.box, !fir.box) -> 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 -- 2.7.4