Reland "[flang] add extra component information in fir.type_info" (#97404)

Reland #96746 with the proper Support/CMakelist.txt change.

fir.type does not contain all Fortran level information about
components. For instance, component lower bounds and default initial
value are lost. For correctness purpose, this does not matter because
this information is "applied" in lowering (e.g., when addressing the
components, the lower bounds are reflected in the hlfir.designate).

However, this "loss" of information will prevent the generation of
correct debug info for the type (needs to know about lower bounds). The
initial value could help building some optimization pass to get rid of
initialization runtime calls.

This patch adds lower bound and initial value information into
fir.type_info via a new fir.dt_component operation. This operation is
generated only for component that needs it, which helps keeping the IR
small for "boring" types.

In general, adding Fortran level info in fir.type_info will allow
delaying the generation of "type descriptors" gobals that are very
verbose in FIR and make it hard to work with FIR dumps from applications
with many derived types.

flang/include/flang/Optimizer/Builder/FIRBuilder.h

@@ -286,6 +286,10 @@ public:
   fir::StringLitOp createStringLitOp(mlir::Location loc,
                                      llvm::StringRef string);
 
+  std::pair<fir::TypeInfoOp, mlir::OpBuilder::InsertPoint>
+  createTypeInfoOp(mlir::Location loc, fir::RecordType recordType,
+                   fir::RecordType parentType);
+
   //===--------------------------------------------------------------------===//
   // Linkage helpers (inline). The default linkage is external.
   //===--------------------------------------------------------------------===//

flang/include/flang/Optimizer/Dialect/FIROps.td

@@ -2956,7 +2956,10 @@ def fir_TypeInfoOp : fir_Op<"type_info",
 
   let hasVerifier = 1;
 
-  let regions = (region MaxSizedRegion<1>:$dispatch_table);
+  let regions = (region
+    MaxSizedRegion<1>:$dispatch_table,
+    MaxSizedRegion<1>:$component_info
+  );
 
   let builders = [
     OpBuilder<(ins "fir::RecordType":$type, "fir::RecordType":$parent_type,
@@ -2967,6 +2970,7 @@ def fir_TypeInfoOp : fir_Op<"type_info",
     $sym_name (`noinit` $no_init^)? (`nodestroy` $no_destroy^)?
     (`nofinal` $no_final^)? (`extends` $parent_type^)? attr-dict `:` $type
     (`dispatch_table` $dispatch_table^)?
+    (`component_info` $component_info^)?
   }];
 
   let extraClassDeclaration = [{
@@ -3010,6 +3014,24 @@ def fir_DTEntryOp : fir_Op<"dt_entry", [HasParent<"TypeInfoOp">]> {
   }];
 }
 
+def fir_DTComponentOp : fir_Op<"dt_component", [HasParent<"TypeInfoOp">]> {
+  let summary = "define extra information about a component inside fir.type_info";
+
+  let description = [{
+    ```
+      fir.dt_component i lbs [-1,2] init @init_val
+    ```
+  }];
+
+  let arguments = (ins
+    StrAttr:$name,
+    OptionalAttr<DenseI64ArrayAttr>:$lower_bounds,
+    OptionalAttr<FlatSymbolRefAttr>:$init_val
+  );
+
+  let assemblyFormat = "$name (`lbs` $lower_bounds^)? (`init` $init_val^)? attr-dict";
+}
+
 def fir_AbsentOp : fir_OneResultOp<"absent", [NoMemoryEffect]> {
   let summary = "create value to be passed for absent optional function argument";
   let description = [{

flang/include/flang/Optimizer/Support/InternalNames.h

@@ -15,6 +15,7 @@
 #include <optional>
 
 static constexpr llvm::StringRef typeDescriptorSeparator = ".dt.";
+static constexpr llvm::StringRef componentInitSeparator = ".di.";
 static constexpr llvm::StringRef bindingTableSeparator = ".v.";
 static constexpr llvm::StringRef boxprocSuffix = "UnboxProc";
 
@@ -156,6 +157,11 @@ struct NameUniquer {
   static std::string
   getTypeDescriptorBindingTableName(llvm::StringRef mangledTypeName);
 
+  /// Given a mangled derived type name and a component name, get the name of
+  /// the global object containing the component default initialization.
+  static std::string getComponentInitName(llvm::StringRef mangledTypeName,
+                                          llvm::StringRef componentName);
+
   /// Remove markers that have been added when doing partial type
   /// conversions. mlir::Type cannot be mutated in a pass, so new
   /// fir::RecordType must be created when lowering member types.

flang/include/flang/Optimizer/Support/Utils.h

@@ -137,6 +137,29 @@ inline void intrinsicTypeTODO(fir::FirOpBuilder &builder, mlir::Type type,
            " in " + intrinsicName);
 }
 
+/// Find the fir.type_info that was created for this \p recordType in \p module,
+/// if any. \p  symbolTable can be provided to speed-up the lookup. This tool
+/// will match record type even if they have been "altered" in type conversion
+/// passes.
+fir::TypeInfoOp
+lookupTypeInfoOp(fir::RecordType recordType, mlir::ModuleOp module,
+                 const mlir::SymbolTable *symbolTable = nullptr);
+
+/// Find the fir.type_info named \p name in \p module, if any. \p  symbolTable
+/// can be provided to speed-up the lookup. Prefer using the equivalent with a
+/// RecordType argument  unless it is certain \p name has not been altered by a
+/// pass rewriting fir.type (see NameUniquer::dropTypeConversionMarkers).
+fir::TypeInfoOp
+lookupTypeInfoOp(llvm::StringRef name, mlir::ModuleOp module,
+                 const mlir::SymbolTable *symbolTable = nullptr);
+
+/// Returns all lower bounds of \p component if it is an array component of \p
+/// recordType with non default lower bounds. Returns nullopt if this is not an
+/// array componnet of \p recordType or if its lower bounds are all ones.
+std::optional<llvm::ArrayRef<int64_t>> getComponentLowerBoundsIfNonDefault(
+    fir::RecordType recordType, llvm::StringRef component,
+    mlir::ModuleOp module, const mlir::SymbolTable *symbolTable = nullptr);
+
 } // namespace fir
 
 #endif // FORTRAN_OPTIMIZER_SUPPORT_UTILS_H

flang/lib/Lower/Bridge.cpp

@@ -148,6 +148,71 @@ struct ConstructContext {
   bool pushedScope = false; // was a scoped pushed for this construct?
 };
 
+/// Helper to gather the lower bounds of array components with non deferred
+/// shape when they are not all ones. Return an empty array attribute otherwise.
+static mlir::DenseI64ArrayAttr
+gatherComponentNonDefaultLowerBounds(mlir::Location loc,
+                                     mlir::MLIRContext *mlirContext,
+                                     const Fortran::semantics::Symbol &sym) {
+  if (Fortran::semantics::IsAllocatableOrObjectPointer(&sym))
+    return {};
+  mlir::DenseI64ArrayAttr lbs_attr;
+  if (const auto *objDetails =
+          sym.detailsIf<Fortran::semantics::ObjectEntityDetails>()) {
+    llvm::SmallVector<std::int64_t> lbs;
+    bool hasNonDefaultLbs = false;
+    for (const Fortran::semantics::ShapeSpec &bounds : objDetails->shape())
+      if (auto lb = bounds.lbound().GetExplicit()) {
+        if (auto constant = Fortran::evaluate::ToInt64(*lb)) {
+          hasNonDefaultLbs |= (*constant != 1);
+          lbs.push_back(*constant);
+        } else {
+          TODO(loc, "generate fir.dt_component for length parametrized derived "
+                    "types");
+        }
+      }
+    if (hasNonDefaultLbs) {
+      assert(static_cast<int>(lbs.size()) == sym.Rank() &&
+             "expected component bounds to be constant or deferred");
+      lbs_attr = mlir::DenseI64ArrayAttr::get(mlirContext, lbs);
+    }
+  }
+  return lbs_attr;
+}
+
+// Helper class to generate name of fir.global containing component explicit
+// default value for objects, and initial procedure target for procedure pointer
+// components.
+static mlir::FlatSymbolRefAttr gatherComponentInit(
+    mlir::Location loc, Fortran::lower::AbstractConverter &converter,
+    const Fortran::semantics::Symbol &sym, fir::RecordType derivedType) {
+  mlir::MLIRContext *mlirContext = &converter.getMLIRContext();
+  // Return procedure target mangled name for procedure pointer components.
+  if (const auto *procPtr =
+          sym.detailsIf<Fortran::semantics::ProcEntityDetails>()) {
+    if (std::optional<const Fortran::semantics::Symbol *> maybeInitSym =
+            procPtr->init()) {
+      // So far, do not make distinction between p => NULL() and p without init,
+      // f18 always initialize pointers to NULL anyway.
+      if (!*maybeInitSym)
+        return {};
+      return mlir::FlatSymbolRefAttr::get(mlirContext,
+                                          converter.mangleName(**maybeInitSym));
+    }
+  }
+
+  const auto *objDetails =
+      sym.detailsIf<Fortran::semantics::ObjectEntityDetails>();
+  if (!objDetails || !objDetails->init().has_value())
+    return {};
+  // Object component initial value. Semantic package component object default
+  // value into compiler generated symbols that are lowered as read-only
+  // fir.global. Get the name of this global.
+  std::string name = fir::NameUniquer::getComponentInitName(
+      derivedType.getName(), toStringRef(sym.name()));
+  return mlir::FlatSymbolRefAttr::get(mlirContext, name);
+}
+
 /// Helper class to generate the runtime type info global data and the
 /// fir.type_info operations that contain the dipatch tables (if any).
 /// The type info global data is required to describe the derived type to the
@@ -213,15 +278,14 @@ private:
       parentType = mlir::cast<fir::RecordType>(converter.genType(*parent));
 
     fir::FirOpBuilder &builder = converter.getFirOpBuilder();
-    mlir::ModuleOp module = builder.getModule();
-    fir::TypeInfoOp dt =
-        module.lookupSymbol<fir::TypeInfoOp>(info.type.getName());
-    if (dt)
-      return; // Already created.
-    auto insertPt = builder.saveInsertionPoint();
-    builder.setInsertionPoint(module.getBody(), module.getBody()->end());
-    dt = builder.create<fir::TypeInfoOp>(info.loc, info.type, parentType);
+    fir::TypeInfoOp dt;
+    mlir::OpBuilder::InsertPoint insertPointIfCreated;
+    std::tie(dt, insertPointIfCreated) =
+        builder.createTypeInfoOp(info.loc, info.type, parentType);
+    if (!insertPointIfCreated.isSet())
+      return; // fir.type_info was already built in a previous call.
 
+    // Set init, destroy, and nofinal attributes.
     if (!info.typeSpec.HasDefaultInitialization(/*ignoreAllocatable=*/false,
                                                 /*ignorePointer=*/false))
       dt->setAttr(dt.getNoInitAttrName(), builder.getUnitAttr());
@@ -230,13 +294,12 @@ private:
     if (!Fortran::semantics::MayRequireFinalization(info.typeSpec))
       dt->setAttr(dt.getNoFinalAttrName(), builder.getUnitAttr());
 
-    const Fortran::semantics::Scope *scope = info.typeSpec.scope();
-    if (!scope)
-      scope = info.typeSpec.typeSymbol().scope();
-    assert(scope && "failed to find type scope");
+    const Fortran::semantics::Scope &derivedScope =
+        DEREF(info.typeSpec.GetScope());
 
+    // Fill binding table region if the derived type has bindings.
     Fortran::semantics::SymbolVector bindings =
-        Fortran::semantics::CollectBindings(*scope);
+        Fortran::semantics::CollectBindings(derivedScope);
     if (!bindings.empty()) {
       builder.createBlock(&dt.getDispatchTable());
       for (const Fortran::semantics::SymbolRef &binding : bindings) {
@@ -252,7 +315,33 @@ private:
       }
       builder.create<fir::FirEndOp>(info.loc);
     }
-    builder.restoreInsertionPoint(insertPt);
+    // Gather info about components that is not reflected in fir.type and may be
+    // needed later: component initial values and array component non default
+    // lower bounds.
+    mlir::Block *componentInfo = nullptr;
+    for (const auto &componentName :
+         info.typeSpec.typeSymbol()
+             .get<Fortran::semantics::DerivedTypeDetails>()
+             .componentNames()) {
+      auto scopeIter = derivedScope.find(componentName);
+      assert(scopeIter != derivedScope.cend() &&
+             "failed to find derived type component symbol");
+      const Fortran::semantics::Symbol &component = scopeIter->second.get();
+      mlir::FlatSymbolRefAttr init_val =
+          gatherComponentInit(info.loc, converter, component, info.type);
+      mlir::DenseI64ArrayAttr lbs = gatherComponentNonDefaultLowerBounds(
+          info.loc, builder.getContext(), component);
+      if (init_val || lbs) {
+        if (!componentInfo)
+          componentInfo = builder.createBlock(&dt.getComponentInfo());
+        auto compName = mlir::StringAttr::get(builder.getContext(),
+                                              toStringRef(component.name()));
+        builder.create<fir::DTComponentOp>(info.loc, compName, lbs, init_val);
+      }
+    }
+    if (componentInfo)
+      builder.create<fir::FirEndOp>(info.loc);
+    builder.restoreInsertionPoint(insertPointIfCreated);
   }
 
   /// Store the front-end data that will be required to generate the type info

flang/lib/Optimizer/Builder/FIRBuilder.cpp

@@ -19,6 +19,7 @@
 #include "flang/Optimizer/Dialect/FIRType.h"
 #include "flang/Optimizer/Support/FatalError.h"
 #include "flang/Optimizer/Support/InternalNames.h"
+#include "flang/Optimizer/Support/Utils.h"
 #include "mlir/Dialect/LLVMIR/LLVMDialect.h"
 #include "mlir/Dialect/OpenACC/OpenACC.h"
 #include "mlir/Dialect/OpenMP/OpenMPDialect.h"
@@ -364,6 +365,22 @@ fir::GlobalOp fir::FirOpBuilder::createGlobal(
   return glob;
 }
 
+std::pair<fir::TypeInfoOp, mlir::OpBuilder::InsertPoint>
+fir::FirOpBuilder::createTypeInfoOp(mlir::Location loc,
+                                    fir::RecordType recordType,
+                                    fir::RecordType parentType) {
+  mlir::ModuleOp module = getModule();
+  if (fir::TypeInfoOp typeInfo =
+          fir::lookupTypeInfoOp(recordType.getName(), module, symbolTable))
+    return {typeInfo, InsertPoint{}};
+  InsertPoint insertPoint = saveInsertionPoint();
+  setInsertionPoint(module.getBody(), module.getBody()->end());
+  auto typeInfo = create<fir::TypeInfoOp>(loc, recordType, parentType);
+  if (symbolTable)
+    symbolTable->insert(typeInfo);
+  return {typeInfo, insertPoint};
+}
+
 mlir::Value fir::FirOpBuilder::convertWithSemantics(
     mlir::Location loc, mlir::Type toTy, mlir::Value val,
     bool allowCharacterConversion, bool allowRebox) {

flang/lib/Optimizer/Dialect/FIROps.cpp

@@ -1579,6 +1579,7 @@ void fir::TypeInfoOp::build(mlir::OpBuilder &builder,
                             fir::RecordType parentType,
                             llvm::ArrayRef<mlir::NamedAttribute> attrs) {
   result.addRegion();
+  result.addRegion();
   result.addAttribute(mlir::SymbolTable::getSymbolAttrName(),
                       builder.getStringAttr(type.getName()));
   result.addAttribute(getTypeAttrName(result.name), mlir::TypeAttr::get(type));

flang/lib/Optimizer/Support/CMakeLists.txt

@@ -5,6 +5,7 @@ add_flang_library(FIRSupport
   DataLayout.cpp
   InitFIR.cpp
   InternalNames.cpp
+  Utils.cpp
 
   DEPENDS
   FIROpsIncGen
@@ -14,6 +15,7 @@ add_flang_library(FIRSupport
   ${extension_libs}
 
   LINK_LIBS
+  FIRDialect
   ${dialect_libs}
   ${extension_libs}
   MLIRBuiltinToLLVMIRTranslation

flang/lib/Optimizer/Support/InternalNames.cpp

@@ -381,6 +381,15 @@ std::string fir::NameUniquer::getTypeDescriptorBindingTableName(
   return getDerivedTypeObjectName(mangledTypeName, bindingTableSeparator);
 }
 
+std::string
+fir::NameUniquer::getComponentInitName(llvm::StringRef mangledTypeName,
+                                       llvm::StringRef componentName) {
+
+  std::string prefix =
+      getDerivedTypeObjectName(mangledTypeName, componentInitSeparator);
+  return prefix + "." + componentName.str();
+}
+
 llvm::StringRef
 fir::NameUniquer::dropTypeConversionMarkers(llvm::StringRef mangledTypeName) {
   if (mangledTypeName.ends_with(boxprocSuffix))

flang/lib/Optimizer/Support/Utils.cpp

@@ -0,0 +1,52 @@
+//===-- Utils.cpp ---------------------------------------------------------===//
+//
+// Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
+// See https://llvm.org/LICENSE.txt for license information.
+// SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
+//
+//===----------------------------------------------------------------------===//
+//
+// Coding style: https://mlir.llvm.org/getting_started/DeveloperGuide/
+//
+//===----------------------------------------------------------------------===//
+
+#include "flang/Optimizer/Support/Utils.h"
+#include "flang/Optimizer/Dialect/FIROps.h"
+#include "flang/Optimizer/Dialect/FIRType.h"
+#include "flang/Optimizer/Support/InternalNames.h"
+
+fir::TypeInfoOp fir::lookupTypeInfoOp(fir::RecordType recordType,
+                                      mlir::ModuleOp module,
+                                      const mlir::SymbolTable *symbolTable) {
+  // fir.type_info was created with the mangled name of the derived type.
+  // It is the same as the name in the related fir.type, except when a pass
+  // lowered the fir.type (e.g., when lowering fir.boxproc type if the type has
+  // pointer procedure components), in which case suffix may have been added to
+  // the fir.type name. Get rid of them when looking up for the fir.type_info.
+  llvm::StringRef originalMangledTypeName =
+      fir::NameUniquer::dropTypeConversionMarkers(recordType.getName());
+  return fir::lookupTypeInfoOp(originalMangledTypeName, module, symbolTable);
+}
+
+fir::TypeInfoOp fir::lookupTypeInfoOp(llvm::StringRef name,
+                                      mlir::ModuleOp module,
+                                      const mlir::SymbolTable *symbolTable) {
+  if (symbolTable)
+    if (auto typeInfo = symbolTable->lookup<fir::TypeInfoOp>(name))
+      return typeInfo;
+  return module.lookupSymbol<fir::TypeInfoOp>(name);
+}
+
+std::optional<llvm::ArrayRef<int64_t>> fir::getComponentLowerBoundsIfNonDefault(
+    fir::RecordType recordType, llvm::StringRef component,
+    mlir::ModuleOp module, const mlir::SymbolTable *symbolTable) {
+  fir::TypeInfoOp typeInfo =
+      fir::lookupTypeInfoOp(recordType, module, symbolTable);
+  if (!typeInfo || typeInfo.getComponentInfo().empty())
+    return std::nullopt;
+  for (auto componentInfo :
+       typeInfo.getComponentInfo().getOps<fir::DTComponentOp>())
+    if (componentInfo.getName() == component)
+      return componentInfo.getLowerBounds();
+  return std::nullopt;
+}

flang/test/Fir/fir-ops.fir

@@ -460,6 +460,13 @@ fir.type_info @dispatch_tbl : !fir.type<dispatch_tbl{i:i32}> dispatch_table {
 // CHECK-LABEL: fir.type_info @test_type_info noinit nodestroy nofinal extends !fir.type<parent{i:i32}> : !fir.type<test_type_info{i:i32,j:f32}>
 fir.type_info @test_type_info noinit nodestroy nofinal extends !fir.type<parent{i:i32}> : !fir.type<test_type_info{i:i32,j:f32}>
 
+// CHECK-LABEL: fir.type_info @cpinfo : !fir.type<cpinfo{comp_i:!fir.array<10x20xi32>}> component_info {
+// CHECK: fir.dt_component "component_info" lbs [2, 3]
+// CHECK: }
+fir.type_info @cpinfo : !fir.type<cpinfo{comp_i:!fir.array<10x20xi32>}> component_info {
+  fir.dt_component "component_info" lbs [2, 3]
+}
+
 // CHECK-LABEL: func @compare_complex(
 // CHECK-SAME: [[VAL_151:%.*]]: !fir.complex<16>, [[VAL_152:%.*]]: !fir.complex<16>) {
 func.func @compare_complex(%a : !fir.complex<16>, %b : !fir.complex<16>) {

flang/test/Lower/HLFIR/type-info-components.f90

@@ -0,0 +1,55 @@
+! Test generation of fir.dt_component
+! RUN: bbc -emit-hlfir %s -o - | FileCheck %s
+subroutine test_1(x)
+  integer, save, target :: my_target
+  procedure() :: my_proc
+  type :: sometype
+    integer :: i(-1:8) = 42
+    integer :: j(1:8)
+    integer, allocatable :: alloc(:)
+    integer, pointer :: p => my_target
+    integer, pointer :: p2 => NULL()
+    integer, pointer :: p3
+    procedure(), pointer, nopass :: proc_p => my_proc
+    procedure(), pointer, nopass :: proc_p2 => NULL()
+    procedure(), pointer, nopass :: proc_p3
+  end type
+  type(sometype) :: x
+end subroutine
+! CHECK-LABEL:   fir.type_info @_QFtest_1Tsometype
+! CHECK-SAME     component_info {
+! CHECK:           fir.dt_component "i" lbs [-1] init @_QFtest_1E.di.sometype.i
+! CHECK-NOT:       fir.dt_component "j"
+! CHECK:           fir.dt_component "p" init @_QFtest_1E.di.sometype.p
+! CHECK:           fir.dt_component "p2" init @_QFtest_1E.di.sometype.p2
+! CHECK:           fir.dt_component "proc_p" init @_QPmy_proc
+! CHECK:         }
+
+subroutine test_nesting(x)
+  type some_sub_type
+    integer :: i = 42
+  end type
+  type sometype2
+    type(some_sub_type) :: nested
+  end type
+  type(sometype2) :: x
+end subroutine
+! CHECK-LABEL:   fir.type_info @_QFtest_nestingTsome_sub_type
+! CHECK-SAME     component_info {
+! CHECK:           fir.dt_component "i" init @_QFtest_nestingE.di.some_sub_type.i
+! CHECK:         }
+
+! CHECK:         fir.type_info @_QFtest_nestingTsometype2
+! CHECK-NOT:       fir.dt_component
+
+
+subroutine data_like(x)
+  type sometype3
+    integer :: i/42/
+  end type
+  type(sometype3) :: x
+end subroutine
+! CHECK-LABEL:   fir.type_info @_QFdata_likeTsometype3
+! CHECK-SAME     component_info {
+! CHECK:           fir.dt_component "i" init @_QFdata_likeE.di.sometype3.i
+! CHECK:         }