[flang] Lowering and implementation for same_type_as

[clementval]

Summary

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.

[clementval]

Remove blank line

[clementval]

clang-format

[clementval]

Brace initialization

[jeanPerier]

flang/runtime/derived-api.cpp

88

As I understand, the standard is leaving processor dependent the case where both entities are unlimited polymorphic and their dynamic types are intrinsic types ("If neither A nor B has extensible dynamic type, the result is processor dependent.") and the code here choses to return false in that case.

I do not have motivations to chose one or the other, but I would rather @klausler to weight in and the processor dependent behavior to be documented in Extensions.md.

95

On the one hand the note 16.29 is pretty clear and your code is in line with this. On the other hand, it breaks my understanding of Fortran. I do not understand how "the dynamic type of A is the same as the dynamic type of B" in the requirement implies that they can have different kind parameters... @klausler is the note 16.29 really in line what is in actual requirements ?

[jeanPerier]

flang/runtime/derived-api.cpp

95

It looks like folding is indeed ignoring type and length parameters when it can fold SAME_TYPE_AS (https://github.com/llvm/llvm-project/blob/94896994386d2a6a9e7bc310de83ee1491f194ef/flang/lib/Evaluate/fold-logical.cpp#L212-L213).

So there is not doubt about what needs to be done, but I do not understand how the Note can be deduced from the requirement.

[PeteSteinfeld]

Aside from checking about unlimited polymorphic type comparisons, all builds and tests correctly and looks good.

flang/runtime/derived-api.cpp

88

Section 7.3.2.2, paragraph 3 states

An entity that is declared using the TYPE(*) type specifier is assumed-type and is an unlimited polymorphic entity. It is not declared to have a type, and is not considered to have the same declared type as any other entity, including another unlimited polymorphic entity.

This seems to me to state that any two unlimited polymorphic types are different.

Still, I agree with Jean that it would be good to consult with @klausler.

[clementval]

flang/runtime/derived-api.cpp

95

On the one hand the note 16.29 is pretty clear and your code is in line with this. On the other hand, it breaks my understanding of Fortran. I do not understand how "the dynamic type of A is the same as the dynamic type of B" in the requirement implies that they can have different kind parameters... @klausler is the note 16.29 really in line what is in actual requirements ?

I think the confusion comes from the fact that we are folding the kind type parameter in the derived type directly. This is an implementation detail of flang and we could imagine the dynamic type to be the same if we do not fold the kind parameters. Therefore if we ignore the kind parameters the dynamic type would be the same. At least that is my understanding.

[klausler]

flang/runtime/derived-api.cpp

88

TYPE(*) dummy arguments don't have (declared) types, so they're like NaNs in tests for equality.

CLASS(*) objects also don't have declared types, so they should also compare unequal.

I don't see a good reason for SAME_TYPE_AS() to ever return .true. unless its arguments really do have the same dynamic declared type, ignoring all parameters.

95

is the note 16.29 really in line what is in actual requirements ?

I can't find a "note 16.29" in my copy of the standard. Do you mean "note 2" in section 16.9.165? If so, yes, I think same_type_as ignores kind type parameters entirely. Which seems silly to me, but that's what somebody wanted.

[jeanPerier]

LGTM

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

void genDerivedTypeDestroy(fir::FirOpBuilder &builder, mlir::Location loc,
                            mlir::Value box);
 
 /// Generate call to `PointerNullifyDerived` runtime function to nullify
 /// 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);
+
 } // namespace fir::runtime
 #endif // FORTRAN_OPTIMIZER_BUILDER_RUNTIME_DERIVED_H

flang/include/flang/Runtime/derived-api.h

 // conversion.
 void RTNAME(Assign)(const Descriptor &, const Descriptor &,
     const char *sourceFile = nullptr, int sourceLine = 0);
 
 // 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 &);
+
 } // extern "C"
 } // namespace Fortran::runtime
 #endif // FORTRAN_RUNTIME_DERIVED_API_H_

flang/lib/Lower/IntrinsicCall.cpp

 #include "flang/Lower/StatementContext.h"
 #include "flang/Lower/SymbolMap.h"
 #include "flang/Optimizer/Builder/Character.h"
 #include "flang/Optimizer/Builder/Complex.h"
 #include "flang/Optimizer/Builder/FIRBuilder.h"
 #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"
 #include "flang/Optimizer/Builder/Runtime/Reduction.h"
 #include "flang/Optimizer/Builder/Runtime/Stop.h"
 #include "flang/Optimizer/Builder/Runtime/Transformational.h"
 #include "flang/Optimizer/Builder/Todo.h"
 #include "flang/Optimizer/Dialect/FIROpsSupport.h"
struct IntrinsicLibrary {
   void genRandomInit(llvm::ArrayRef<fir::ExtendedValue>);
   void genRandomNumber(llvm::ArrayRef<fir::ExtendedValue>);
   void genRandomSeed(llvm::ArrayRef<fir::ExtendedValue>);
   fir::ExtendedValue genReduce(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
   fir::ExtendedValue genRepeat(mlir::Type, llvm::ArrayRef<fir::ExtendedValue>);
   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>);
   mlir::Value genSelectedRealKind(mlir::Type, llvm::ArrayRef<mlir::Value>);
   mlir::Value genSetExponent(mlir::Type resultType,
                              llvm::ArrayRef<mlir::Value> args);
   template <typename Shift>
   mlir::Value genShift(mlir::Type resultType, llvm::ArrayRef<mlir::Value>);
static constexpr IntrinsicHandler handlers[]{
     {"reshape",
      &I::genReshape,
      {{{"source", asBox},
        {"shape", asBox},
        {"pad", asBox, handleDynamicOptional},
        {"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}}},
      /*isElemental=*/true},
     {"scan",
      &I::genScan,
      {{{"string", asAddr},
        {"set", asAddr},
mlir::Value IntrinsicLibrary::genRRSpacing(mlir::Type resultType,
                                            llvm::ArrayRef<mlir::Value> args) {
   assert(args.size() == 1);
 
   return builder.createConvert(
       loc, 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) {
   assert(args.size() == 2);
 
   mlir::Value realX = fir::getBase(args[0]);
   mlir::Value intI = fir::getBase(args[1]);
 

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

void fir::runtime::genNullifyDerivedType(fir::FirOpBuilder &builder,
   args.push_back(builder.createConvert(loc, inputTypes[0], box));
   args.push_back(builder.createConvert(loc, inputTypes[1], typeDescAddr));
   mlir::Value rankCst = builder.createIntegerConstant(loc, inputTypes[2], rank);
   mlir::Value c0 = builder.createIntegerConstant(loc, inputTypes[3], 0);
   args.push_back(rankCst);
   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

if (const auto *derived{addendum->derivedType()}) {
         }
         parent = parent->GetParentType();
       }
     }
   }
   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"
 } // namespace Fortran::runtime

flang/test/Lower/Intrinsics/same_type_as.f90

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