[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

Author: clementval

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

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_

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) {

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);
+}

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"

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