[flang] Lowering and implementation for extends_type_of

[clementval]

Summary

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

[clementval]

clang-format

[jeanPerier]

LGTM, I think it is also worth adding @klausler as a reviewer on this review.

[PeteSteinfeld]

All builds and tests correctly and looks good to me.

flang/include/flang/Optimizer/Builder/Runtime/Derived.h

 /// and set the correct dynamic type to a boxed derived type.
 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);
 
+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

 
 // Perform the test of the CLASS IS type guard statement of the SELECT TYPE
 // 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 &);
 
+// 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

struct IntrinsicLibrary {
   fir::ExtendedValue genDotProduct(mlir::Type,
                                    llvm::ArrayRef<fir::ExtendedValue>);
   mlir::Value genDprod(mlir::Type, llvm::ArrayRef<mlir::Value>);
   mlir::Value genDshiftl(mlir::Type, llvm::ArrayRef<mlir::Value>);
   mlir::Value genDshiftr(mlir::Type, llvm::ArrayRef<mlir::Value>);
   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>);
   mlir::Value genFraction(mlir::Type resultType,
                           mlir::ArrayRef<mlir::Value> args);
   void genGetCommand(mlir::ArrayRef<fir::ExtendedValue> args);
   void genGetCommandArgument(mlir::ArrayRef<fir::ExtendedValue> args);
   void genGetEnvironmentVariable(llvm::ArrayRef<fir::ExtendedValue>);
&I::genEoshift,
        {"boundary", asBox, handleDynamicOptional},
        {"dim", asValue}}},
      /*isElemental=*/false},
     {"exit",
      &I::genExit,
      {{{"status", asValue, handleDynamicOptional}}},
      /*isElemental=*/false},
     {"exponent", &I::genExponent},
+    {"extends_type_of",
+     &I::genExtendsTypeOf,
+     {{{"a", asBox}, {"mold", asBox}}},
+     /*isElemental=*/false},
     {"findloc",
      &I::genFindloc,
      {{{"array", asBox},
        {"value", asAddr},
        {"dim", asValue},
        {"mask", asBox, handleDynamicOptional},
        {"kind", asValue},
        {"back", asValue, handleDynamicOptional}}},
mlir::Value IntrinsicLibrary::genExponent(mlir::Type resultType,
   assert(args.size() == 1);
 
   return builder.createConvert(
       loc, resultType,
       fir::runtime::genExponent(builder, loc, 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,
                              llvm::ArrayRef<fir::ExtendedValue> args) {
   assert(args.size() == 6);
 
   llvm::StringRef errMsg = "unexpected result for Findloc";
 

flang/lib/Optimizer/Builder/Runtime/Derived.cpp

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

if (a.raw().version == CFI_VERSION &&
       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;
 }
 
+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()}) {
       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());
 }
 
+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"
 } // namespace Fortran::runtime

flang/test/Lower/Intrinsics/extends_type_of.f90

+! 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