[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

diff --git a/flang/include/flang/Optimizer/Builder/Runtime/Derived.h b/flang/include/flang/Optimizer/Builder/Runtime/Derived.h
index 239eab1..076f7bd 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 8700c9e..b284036 100644 (file)
--- 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 5817296..722ae11 100644 (file)
--- 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 (file)
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<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