[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

Author: clementval

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

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_

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,

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

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"

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