lib/Lower/HostAssociations.cpp

//===-- HostAssociations.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
//
//===----------------------------------------------------------------------===//

#include "flang/Lower/HostAssociations.h"
#include "flang/Evaluate/check-expression.h"
#include "flang/Lower/AbstractConverter.h"
#include "flang/Lower/Allocatable.h"
#include "flang/Lower/BoxAnalyzer.h"
#include "flang/Lower/CallInterface.h"
#include "flang/Lower/ConvertType.h"
#include "flang/Lower/ConvertVariable.h"
#include "flang/Lower/OpenMP.h"
#include "flang/Lower/PFTBuilder.h"
#include "flang/Lower/SymbolMap.h"
#include "flang/Optimizer/Builder/Character.h"
#include "flang/Optimizer/Builder/FIRBuilder.h"
#include "flang/Optimizer/Builder/Todo.h"
#include "flang/Optimizer/Support/FatalError.h"
#include "flang/Semantics/tools.h"
#include "llvm/ADT/TypeSwitch.h"
#include "llvm/Support/Debug.h"
#include <optional>

#define DEBUG_TYPE "flang-host-assoc"

// Host association inside internal procedures is implemented by allocating an
// mlir tuple (a struct) inside the host containing the addresses and properties
// of variables that are accessed by internal procedures. The address of this
// tuple is passed as an argument by the host when calling internal procedures.
// Internal procedures propagate a reference to this tuple when calling other
// internal procedures of the host.
//
// This file defines how the type of the host tuple is built, how the tuple
// value is created inside the host, and how the host associated variables are
// instantiated inside the internal procedures from the tuple value. The
// CapturedXXX classes define each of these three actions for a specific
// kind of variables by providing a `getType`, a `instantiateHostTuple`, and a
// `getFromTuple` method. These classes are structured as follow:
//
//   class CapturedKindOfVar : public CapturedSymbols<CapturedKindOfVar> {
//     // Return the type of the tuple element for a host associated
//     // variable given its symbol inside the host. This is called when
//     // building function interfaces.
//     static mlir::Type getType();
//     // Build the tuple element value for a host associated variable given its
//     // value inside the host. This is called when lowering the host body.
//     static void instantiateHostTuple();
//     // Instantiate a host variable inside an internal procedure given its
//     // tuple element value. This is called when lowering internal procedure
//     // bodies.
//     static void getFromTuple();
//   };
//
// If a new kind of variable requires ad-hoc handling, a new CapturedXXX class
// should be added to handle it, and `walkCaptureCategories` should be updated
// to dispatch this new kind of variable to this new class.

/// Is \p sym a derived type entity with length parameters ?
static bool isDerivedWithLenParameters(const Fortran::semantics::Symbol &sym) {
  if (const auto *declTy = sym.GetType())
    if (const auto *derived = declTy->AsDerived())
      return Fortran::semantics::CountLenParameters(*derived) != 0;
  return false;
}

/// Map the extracted fir::ExtendedValue for a host associated variable inside
/// and internal procedure to its symbol. Generates an hlfir.declare in HLFIR.
static void bindCapturedSymbol(const Fortran::semantics::Symbol &sym,
                               fir::ExtendedValue val,
                               Fortran::lower::AbstractConverter &converter,
                               Fortran::lower::SymMap &symMap) {
  if (converter.getLoweringOptions().getLowerToHighLevelFIR())
    Fortran::lower::genDeclareSymbol(converter, symMap, sym, val,
                                     fir::FortranVariableFlagsEnum::host_assoc);
  else
    symMap.addSymbol(sym, val);
}

namespace {
/// Struct to be used as argument in walkCaptureCategories when building the
/// tuple element type for a host associated variable.
struct GetTypeInTuple {
  /// walkCaptureCategories must return a type.
  using Result = mlir::Type;
};

/// Struct to be used as argument in walkCaptureCategories when building the
/// tuple element value for a host associated variable.
struct InstantiateHostTuple {
  /// walkCaptureCategories returns nothing.
  using Result = void;
  /// Value of the variable inside the host procedure.
  fir::ExtendedValue hostValue;
  /// Address of the tuple element of the variable.
  mlir::Value addrInTuple;
  mlir::Location loc;
};

/// Struct to be used as argument in walkCaptureCategories when instantiating a
/// host associated variables from its tuple element value.
struct GetFromTuple {
  /// walkCaptureCategories returns nothing.
  using Result = void;
  /// Symbol map inside the internal procedure.
  Fortran::lower::SymMap &symMap;
  /// Value of the tuple element for the host associated variable.
  mlir::Value valueInTuple;
  mlir::Location loc;
};

/// Base class that must be inherited with CRTP by classes defining
/// how host association is implemented for a type of symbol.
/// It simply dispatches visit() calls to the implementations according
/// to the argument type.
template <typename SymbolCategory>
class CapturedSymbols {
public:
  template <typename T>
  static void visit(const T &, Fortran::lower::AbstractConverter &,
                    const Fortran::semantics::Symbol &,
                    const Fortran::lower::BoxAnalyzer &) {
    static_assert(!std::is_same_v<T, T> &&
                  "default visit must not be instantiated");
  }
  static mlir::Type visit(const GetTypeInTuple &,
                          Fortran::lower::AbstractConverter &converter,
                          const Fortran::semantics::Symbol &sym,
                          const Fortran::lower::BoxAnalyzer &) {
    return SymbolCategory::getType(converter, sym);
  }
  static void visit(const InstantiateHostTuple &args,
                    Fortran::lower::AbstractConverter &converter,
                    const Fortran::semantics::Symbol &sym,
                    const Fortran::lower::BoxAnalyzer &) {
    return SymbolCategory::instantiateHostTuple(args, converter, sym);
  }
  static void visit(const GetFromTuple &args,
                    Fortran::lower::AbstractConverter &converter,
                    const Fortran::semantics::Symbol &sym,
                    const Fortran::lower::BoxAnalyzer &ba) {
    return SymbolCategory::getFromTuple(args, converter, sym, ba);
  }
};

/// Class defining simple scalars are captured in internal procedures.
/// Simple scalars are non character intrinsic scalars. They are captured
/// as `!fir.ref<T>`, for example `!fir.ref<i32>` for `INTEGER*4`.
class CapturedSimpleScalars : public CapturedSymbols<CapturedSimpleScalars> {
public:
  static mlir::Type getType(Fortran::lower::AbstractConverter &converter,
                            const Fortran::semantics::Symbol &sym) {
    return fir::ReferenceType::get(converter.genType(sym));
  }

  static void instantiateHostTuple(const InstantiateHostTuple &args,
                                   Fortran::lower::AbstractConverter &converter,
                                   const Fortran::semantics::Symbol &) {
    fir::FirOpBuilder &builder = converter.getFirOpBuilder();
    mlir::Type typeInTuple = fir::dyn_cast_ptrEleTy(args.addrInTuple.getType());
    assert(typeInTuple && "addrInTuple must be an address");
    mlir::Value castBox = builder.createConvert(args.loc, typeInTuple,
                                                fir::getBase(args.hostValue));
    builder.create<fir::StoreOp>(args.loc, castBox, args.addrInTuple);
  }

  static void getFromTuple(const GetFromTuple &args,
                           Fortran::lower::AbstractConverter &converter,
                           const Fortran::semantics::Symbol &sym,
                           const Fortran::lower::BoxAnalyzer &) {
    bindCapturedSymbol(sym, args.valueInTuple, converter, args.symMap);
  }
};

/// Class defining how dummy procedures and procedure pointers
/// are captured in internal procedures.
class CapturedProcedure : public CapturedSymbols<CapturedProcedure> {
public:
  static mlir::Type getType(Fortran::lower::AbstractConverter &converter,
                            const Fortran::semantics::Symbol &sym) {
    mlir::Type funTy = Fortran::lower::getDummyProcedureType(sym, converter);
    if (Fortran::semantics::IsPointer(sym))
      return fir::ReferenceType::get(funTy);
    return funTy;
  }

  static void instantiateHostTuple(const InstantiateHostTuple &args,
                                   Fortran::lower::AbstractConverter &converter,
                                   const Fortran::semantics::Symbol &) {
    fir::FirOpBuilder &builder = converter.getFirOpBuilder();
    mlir::Type typeInTuple = fir::dyn_cast_ptrEleTy(args.addrInTuple.getType());
    assert(typeInTuple && "addrInTuple must be an address");
    mlir::Value castBox = builder.createConvert(args.loc, typeInTuple,
                                                fir::getBase(args.hostValue));
    builder.create<fir::StoreOp>(args.loc, castBox, args.addrInTuple);
  }

  static void getFromTuple(const GetFromTuple &args,
                           Fortran::lower::AbstractConverter &converter,
                           const Fortran::semantics::Symbol &sym,
                           const Fortran::lower::BoxAnalyzer &) {
    bindCapturedSymbol(sym, args.valueInTuple, converter, args.symMap);
  }
};

/// Class defining how character scalars are captured in internal procedures.
/// Character scalars are passed as !fir.boxchar<kind> in the tuple.
class CapturedCharacterScalars
    : public CapturedSymbols<CapturedCharacterScalars> {
public:
  // Note: so far, do not specialize constant length characters. They can be
  // implemented by only passing the address. This could be done later in
  // lowering or a CapturedStaticLenCharacterScalars class could be added here.

  static mlir::Type getType(Fortran::lower::AbstractConverter &converter,
                            const Fortran::semantics::Symbol &sym) {
    fir::KindTy kind =
        mlir::cast<fir::CharacterType>(converter.genType(sym)).getFKind();
    return fir::BoxCharType::get(&converter.getMLIRContext(), kind);
  }

  static void instantiateHostTuple(const InstantiateHostTuple &args,
                                   Fortran::lower::AbstractConverter &converter,
                                   const Fortran::semantics::Symbol &) {
    const fir::CharBoxValue *charBox = args.hostValue.getCharBox();
    assert(charBox && "host value must be a fir::CharBoxValue");
    fir::FirOpBuilder &builder = converter.getFirOpBuilder();
    mlir::Value boxchar = fir::factory::CharacterExprHelper(builder, args.loc)
                              .createEmbox(*charBox);
    builder.create<fir::StoreOp>(args.loc, boxchar, args.addrInTuple);
  }

  static void getFromTuple(const GetFromTuple &args,
                           Fortran::lower::AbstractConverter &converter,
                           const Fortran::semantics::Symbol &sym,
                           const Fortran::lower::BoxAnalyzer &) {
    fir::factory::CharacterExprHelper charHelp(converter.getFirOpBuilder(),
                                               args.loc);
    std::pair<mlir::Value, mlir::Value> unboxchar =
        charHelp.createUnboxChar(args.valueInTuple);
    bindCapturedSymbol(sym,
                       fir::CharBoxValue{unboxchar.first, unboxchar.second},
                       converter, args.symMap);
  }
};

/// Class defining how polymorphic scalar entities are captured in internal
/// procedures. Polymorphic entities are always boxed as a fir.class box.
/// Polymorphic array can be handled in CapturedArrays directly
class CapturedPolymorphicScalar
    : public CapturedSymbols<CapturedPolymorphicScalar> {
public:
  static mlir::Type getType(Fortran::lower::AbstractConverter &converter,
                            const Fortran::semantics::Symbol &sym) {
    return converter.genType(sym);
  }
  static void instantiateHostTuple(const InstantiateHostTuple &args,
                                   Fortran::lower::AbstractConverter &converter,
                                   const Fortran::semantics::Symbol &sym) {
    fir::FirOpBuilder &builder = converter.getFirOpBuilder();
    mlir::Location loc = args.loc;
    mlir::Type typeInTuple = fir::dyn_cast_ptrEleTy(args.addrInTuple.getType());
    assert(typeInTuple && "addrInTuple must be an address");
    mlir::Value castBox = builder.createConvert(args.loc, typeInTuple,
                                                fir::getBase(args.hostValue));
    if (Fortran::semantics::IsOptional(sym)) {
      auto isPresent =
          builder.create<fir::IsPresentOp>(loc, builder.getI1Type(), castBox);
      builder.genIfThenElse(loc, isPresent)
          .genThen([&]() {
            builder.create<fir::StoreOp>(loc, castBox, args.addrInTuple);
          })
          .genElse([&]() {
            mlir::Value null = fir::factory::createUnallocatedBox(
                builder, loc, typeInTuple,
                /*nonDeferredParams=*/mlir::ValueRange{});
            builder.create<fir::StoreOp>(loc, null, args.addrInTuple);
          })
          .end();
    } else {
      builder.create<fir::StoreOp>(loc, castBox, args.addrInTuple);
    }
  }
  static void getFromTuple(const GetFromTuple &args,
                           Fortran::lower::AbstractConverter &converter,
                           const Fortran::semantics::Symbol &sym,
                           const Fortran::lower::BoxAnalyzer &ba) {
    fir::FirOpBuilder &builder = converter.getFirOpBuilder();
    mlir::Location loc = args.loc;
    mlir::Value box = args.valueInTuple;
    if (Fortran::semantics::IsOptional(sym)) {
      auto boxTy = mlir::cast<fir::BaseBoxType>(box.getType());
      auto eleTy = boxTy.getEleTy();
      if (!fir::isa_ref_type(eleTy))
        eleTy = builder.getRefType(eleTy);
      auto addr = builder.create<fir::BoxAddrOp>(loc, eleTy, box);
      mlir::Value isPresent = builder.genIsNotNullAddr(loc, addr);
      auto absentBox = builder.create<fir::AbsentOp>(loc, boxTy);
      box =
          builder.create<mlir::arith::SelectOp>(loc, isPresent, box, absentBox);
    }
    bindCapturedSymbol(sym, box, converter, args.symMap);
  }
};

/// Class defining how allocatable and pointers entities are captured in
/// internal procedures. Allocatable and pointers are simply captured by placing
/// their !fir.ref<fir.box<>> address in the host tuple.
class CapturedAllocatableAndPointer
    : public CapturedSymbols<CapturedAllocatableAndPointer> {
public:
  static mlir::Type getType(Fortran::lower::AbstractConverter &converter,
                            const Fortran::semantics::Symbol &sym) {
    mlir::Type baseType = converter.genType(sym);
    if (sym.GetUltimate().test(Fortran::semantics::Symbol::Flag::CrayPointee))
      return fir::ReferenceType::get(
          Fortran::lower::getCrayPointeeBoxType(baseType));
    return fir::ReferenceType::get(baseType);
  }
  static void instantiateHostTuple(const InstantiateHostTuple &args,
                                   Fortran::lower::AbstractConverter &converter,
                                   const Fortran::semantics::Symbol &) {
    assert(args.hostValue.getBoxOf<fir::MutableBoxValue>() &&
           "host value must be a fir::MutableBoxValue");
    fir::FirOpBuilder &builder = converter.getFirOpBuilder();
    mlir::Type typeInTuple = fir::dyn_cast_ptrEleTy(args.addrInTuple.getType());
    assert(typeInTuple && "addrInTuple must be an address");
    mlir::Value castBox = builder.createConvert(args.loc, typeInTuple,
                                                fir::getBase(args.hostValue));
    builder.create<fir::StoreOp>(args.loc, castBox, args.addrInTuple);
  }
  static void getFromTuple(const GetFromTuple &args,
                           Fortran::lower::AbstractConverter &converter,
                           const Fortran::semantics::Symbol &sym,
                           const Fortran::lower::BoxAnalyzer &ba) {
    fir::FirOpBuilder &builder = converter.getFirOpBuilder();
    mlir::Location loc = args.loc;
    // Non deferred type parameters impact the semantics of some statements
    // where allocatables/pointer can appear. For instance, assignment to a
    // scalar character allocatable with has a different semantics in F2003 and
    // later if the length is non deferred vs when it is deferred. So it is
    // important to keep track of the non deferred parameters here.
    llvm::SmallVector<mlir::Value> nonDeferredLenParams;
    if (ba.isChar()) {
      mlir::IndexType idxTy = builder.getIndexType();
      if (std::optional<int64_t> len = ba.getCharLenConst()) {
        nonDeferredLenParams.push_back(
            builder.createIntegerConstant(loc, idxTy, *len));
      } else if (Fortran::semantics::IsAssumedLengthCharacter(sym) ||
                 ba.getCharLenExpr()) {
        nonDeferredLenParams.push_back(
            Fortran::lower::getAssumedCharAllocatableOrPointerLen(
                builder, loc, sym, args.valueInTuple));
      }
    } else if (isDerivedWithLenParameters(sym)) {
      TODO(loc, "host associated derived type allocatable or pointer with "
                "length parameters");
    }
    bindCapturedSymbol(
        sym, fir::MutableBoxValue(args.valueInTuple, nonDeferredLenParams, {}),
        converter, args.symMap);
  }
};

/// Class defining how arrays, including assumed-ranks, are captured inside
/// internal procedures.
/// Array are captured via a `fir.box<fir.array<T>>` descriptor that belongs to
/// the host tuple. This allows capturing lower bounds, which can be done by
/// providing a ShapeShiftOp argument to the EmboxOp.
class CapturedArrays : public CapturedSymbols<CapturedArrays> {

  // Note: Constant shape arrays are not specialized (their base address would
  // be sufficient information inside the tuple). They could be specialized in
  // a later FIR pass, or a CapturedStaticShapeArrays could be added to deal
  // with them here.
public:
  static mlir::Type getType(Fortran::lower::AbstractConverter &converter,
                            const Fortran::semantics::Symbol &sym) {
    mlir::Type type = converter.genType(sym);
    bool isPolymorphic = Fortran::semantics::IsPolymorphic(sym);
    assert((mlir::isa<fir::SequenceType>(type) ||
            (isPolymorphic && mlir::isa<fir::ClassType>(type))) &&
           "must be a sequence type");
    if (isPolymorphic)
      return type;
    return fir::BoxType::get(type);
  }

  static void instantiateHostTuple(const InstantiateHostTuple &args,
                                   Fortran::lower::AbstractConverter &converter,
                                   const Fortran::semantics::Symbol &sym) {
    fir::FirOpBuilder &builder = converter.getFirOpBuilder();
    mlir::Location loc = args.loc;
    fir::MutableBoxValue boxInTuple(args.addrInTuple, {}, {});
    if (args.hostValue.getBoxOf<fir::BoxValue>() &&
        Fortran::semantics::IsOptional(sym)) {
      // The assumed shape optional case need some care because it is illegal to
      // read the incoming box if it is absent (this would cause segfaults).
      // Pointer association requires reading the target box, so it can only be
      // done on present optional. For absent optionals, simply create a
      // disassociated pointer (it is illegal to inquire about lower bounds or
      // lengths of optional according to 15.5.2.12 3 (9) and 10.1.11 2 (7)b).
      auto isPresent = builder.create<fir::IsPresentOp>(
          loc, builder.getI1Type(), fir::getBase(args.hostValue));
      builder.genIfThenElse(loc, isPresent)
          .genThen([&]() {
            fir::factory::associateMutableBox(builder, loc, boxInTuple,
                                              args.hostValue,
                                              /*lbounds=*/std::nullopt);
          })
          .genElse([&]() {
            fir::factory::disassociateMutableBox(builder, loc, boxInTuple);
          })
          .end();
    } else {
      fir::factory::associateMutableBox(
          builder, loc, boxInTuple, args.hostValue, /*lbounds=*/std::nullopt);
    }
  }

  static void getFromTuple(const GetFromTuple &args,
                           Fortran::lower::AbstractConverter &converter,
                           const Fortran::semantics::Symbol &sym,
                           const Fortran::lower::BoxAnalyzer &ba) {
    fir::FirOpBuilder &builder = converter.getFirOpBuilder();
    mlir::Location loc = args.loc;
    mlir::Value box = args.valueInTuple;
    mlir::IndexType idxTy = builder.getIndexType();
    llvm::SmallVector<mlir::Value> lbounds;
    if (!ba.lboundIsAllOnes() && !Fortran::evaluate::IsAssumedRank(sym)) {
      if (ba.isStaticArray()) {
        for (std::int64_t lb : ba.staticLBound())
          lbounds.emplace_back(builder.createIntegerConstant(loc, idxTy, lb));
      } else {
        // Cannot re-evaluate specification expressions here.
        // Operands values may have changed. Get value from fir.box
        const unsigned rank = sym.Rank();
        for (unsigned dim = 0; dim < rank; ++dim) {
          mlir::Value dimVal = builder.createIntegerConstant(loc, idxTy, dim);
          auto dims = builder.create<fir::BoxDimsOp>(loc, idxTy, idxTy, idxTy,
                                                     box, dimVal);
          lbounds.emplace_back(dims.getResult(0));
        }
      }
    }

    if (canReadCapturedBoxValue(converter, sym)) {
      fir::BoxValue boxValue(box, lbounds, /*explicitParams=*/std::nullopt);
      bindCapturedSymbol(sym,
                         fir::factory::readBoxValue(builder, loc, boxValue),
                         converter, args.symMap);
    } else {
      // Keep variable as a fir.box/fir.class.
      // If this is an optional that is absent, the fir.box needs to be an
      // AbsentOp result, otherwise it will not work properly with IsPresentOp
      // (absent boxes are null descriptor addresses, not descriptors containing
      // a null base address).
      if (Fortran::semantics::IsOptional(sym)) {
        auto boxTy = mlir::cast<fir::BaseBoxType>(box.getType());
        auto eleTy = boxTy.getEleTy();
        if (!fir::isa_ref_type(eleTy))
          eleTy = builder.getRefType(eleTy);
        auto addr = builder.create<fir::BoxAddrOp>(loc, eleTy, box);
        mlir::Value isPresent = builder.genIsNotNullAddr(loc, addr);
        auto absentBox = builder.create<fir::AbsentOp>(loc, boxTy);
        box = builder.create<mlir::arith::SelectOp>(loc, isPresent, box,
                                                    absentBox);
      }
      fir::BoxValue boxValue(box, lbounds, /*explicitParams=*/std::nullopt);
      bindCapturedSymbol(sym, boxValue, converter, args.symMap);
    }
  }

private:
  /// Can the fir.box from the host link be read into simpler values ?
  /// Later, without the symbol information, it might not be possible
  /// to tell if the fir::BoxValue from the host link is contiguous.
  static bool
  canReadCapturedBoxValue(Fortran::lower::AbstractConverter &converter,
                          const Fortran::semantics::Symbol &sym) {
    bool isScalarOrContiguous =
        sym.Rank() == 0 || Fortran::evaluate::IsSimplyContiguous(
                               Fortran::evaluate::AsGenericExpr(sym).value(),
                               converter.getFoldingContext());
    const Fortran::semantics::DeclTypeSpec *type = sym.GetType();
    bool isPolymorphic = type && type->IsPolymorphic();
    return isScalarOrContiguous && !isPolymorphic &&
           !isDerivedWithLenParameters(sym) &&
           !Fortran::evaluate::IsAssumedRank(sym);
  }
};
} // namespace

/// Dispatch \p visitor to the CapturedSymbols which is handling how host
/// association is implemented for this kind of symbols. This ensures the same
/// dispatch decision is taken when building the tuple type, when creating the
/// tuple, and when instantiating host associated variables from it.
template <typename T>
static typename T::Result
walkCaptureCategories(T visitor, Fortran::lower::AbstractConverter &converter,
                      const Fortran::semantics::Symbol &sym) {
  if (isDerivedWithLenParameters(sym))
    // Should be boxed.
    TODO(converter.genLocation(sym.name()),
         "host associated derived type with length parameters");
  Fortran::lower::BoxAnalyzer ba;
  // Do not analyze procedures, they may be subroutines with no types that would
  // crash the analysis.
  if (Fortran::semantics::IsProcedure(sym))
    return CapturedProcedure::visit(visitor, converter, sym, ba);
  ba.analyze(sym);
  if (Fortran::semantics::IsAllocatableOrPointer(sym) ||
      sym.GetUltimate().test(Fortran::semantics::Symbol::Flag::CrayPointee))
    return CapturedAllocatableAndPointer::visit(visitor, converter, sym, ba);
  if (ba.isArray()) // include assumed-ranks.
    return CapturedArrays::visit(visitor, converter, sym, ba);
  if (Fortran::semantics::IsPolymorphic(sym))
    return CapturedPolymorphicScalar::visit(visitor, converter, sym, ba);
  if (ba.isChar())
    return CapturedCharacterScalars::visit(visitor, converter, sym, ba);
  assert(ba.isTrivial() && "must be trivial scalar");
  return CapturedSimpleScalars::visit(visitor, converter, sym, ba);
}

// `t` should be the result of getArgumentType, which has a type of
// `!fir.ref<tuple<...>>`.
static mlir::TupleType unwrapTupleTy(mlir::Type t) {
  return mlir::cast<mlir::TupleType>(fir::dyn_cast_ptrEleTy(t));
}

static mlir::Value genTupleCoor(fir::FirOpBuilder &builder, mlir::Location loc,
                                mlir::Type varTy, mlir::Value tupleArg,
                                mlir::Value offset) {
  // fir.ref<fir.ref> and fir.ptr<fir.ref> are forbidden. Use
  // fir.llvm_ptr if needed.
  auto ty = mlir::isa<fir::ReferenceType>(varTy)
                ? mlir::Type(fir::LLVMPointerType::get(varTy))
                : mlir::Type(builder.getRefType(varTy));
  return builder.create<fir::CoordinateOp>(loc, ty, tupleArg, offset);
}

void Fortran::lower::HostAssociations::addSymbolsToBind(
    const llvm::SetVector<const Fortran::semantics::Symbol *> &symbols,
    const Fortran::semantics::Scope &hostScope) {
  assert(tupleSymbols.empty() && globalSymbols.empty() &&
         "must be initially empty");
  this->hostScope = &hostScope;
  for (const auto *s : symbols)
    // GlobalOp are created for non-global threadprivate variable,
    //  so considering them as globals.
    if (Fortran::lower::symbolIsGlobal(*s) ||
        (*s).test(Fortran::semantics::Symbol::Flag::OmpThreadprivate)) {
      // The ultimate symbol is stored here so that global symbols from the
      // host scope can later be searched in this set.
      globalSymbols.insert(&s->GetUltimate());
    } else {
      tupleSymbols.insert(s);
    }
}

void Fortran::lower::HostAssociations::hostProcedureBindings(
    Fortran::lower::AbstractConverter &converter,
    Fortran::lower::SymMap &symMap) {
  if (tupleSymbols.empty())
    return;

  // Create the tuple variable.
  mlir::TupleType tupTy = unwrapTupleTy(getArgumentType(converter));
  fir::FirOpBuilder &builder = converter.getFirOpBuilder();
  mlir::Location loc = converter.getCurrentLocation();
  auto hostTuple = builder.create<fir::AllocaOp>(loc, tupTy);
  mlir::IntegerType offTy = builder.getIntegerType(32);

  // Walk the list of tupleSymbols and update the pointers in the tuple.
  for (auto s : llvm::enumerate(tupleSymbols)) {
    auto indexInTuple = s.index();
    mlir::Value off = builder.createIntegerConstant(loc, offTy, indexInTuple);
    mlir::Type varTy = tupTy.getType(indexInTuple);
    mlir::Value eleOff = genTupleCoor(builder, loc, varTy, hostTuple, off);
    InstantiateHostTuple instantiateHostTuple{
        converter.getSymbolExtendedValue(*s.value(), &symMap), eleOff, loc};
    walkCaptureCategories(instantiateHostTuple, converter, *s.value());
  }

  converter.bindHostAssocTuple(hostTuple);
}

void Fortran::lower::HostAssociations::internalProcedureBindings(
    Fortran::lower::AbstractConverter &converter,
    Fortran::lower::SymMap &symMap) {
  if (!globalSymbols.empty()) {
    assert(hostScope && "host scope must have been set");
    Fortran::lower::AggregateStoreMap storeMap;
    // The host scope variable list is required to deal with host variables
    // that are equivalenced and requires instantiating the right global
    // AggregateStore.
    for (auto &hostVariable : pft::getScopeVariableList(*hostScope))
      if ((hostVariable.isAggregateStore() && hostVariable.isGlobal()) ||
          (hostVariable.hasSymbol() &&
           globalSymbols.contains(&hostVariable.getSymbol().GetUltimate()))) {
        Fortran::lower::instantiateVariable(converter, hostVariable, symMap,
                                            storeMap);
        // Generate threadprivate Op for host associated variables.
        if (hostVariable.hasSymbol() &&
            hostVariable.getSymbol().test(
                Fortran::semantics::Symbol::Flag::OmpThreadprivate))
          Fortran::lower::genThreadprivateOp(converter, hostVariable);
      }
  }
  if (tupleSymbols.empty())
    return;

  // Find the argument with the tuple type. The argument ought to be appended.
  fir::FirOpBuilder &builder = converter.getFirOpBuilder();
  mlir::Type argTy = getArgumentType(converter);
  mlir::TupleType tupTy = unwrapTupleTy(argTy);
  mlir::Location loc = converter.getCurrentLocation();
  mlir::func::FuncOp func = builder.getFunction();
  mlir::Value tupleArg;
  for (auto [ty, arg] : llvm::reverse(llvm::zip(
           func.getFunctionType().getInputs(), func.front().getArguments())))
    if (ty == argTy) {
      tupleArg = arg;
      break;
    }
  if (!tupleArg)
    fir::emitFatalError(loc, "no host association argument found");

  converter.bindHostAssocTuple(tupleArg);

  mlir::IntegerType offTy = builder.getIntegerType(32);

  // Walk the list and add the bindings to the symbol table.
  for (auto s : llvm::enumerate(tupleSymbols)) {
    mlir::Value off = builder.createIntegerConstant(loc, offTy, s.index());
    mlir::Type varTy = tupTy.getType(s.index());
    mlir::Value eleOff = genTupleCoor(builder, loc, varTy, tupleArg, off);
    mlir::Value valueInTuple = builder.create<fir::LoadOp>(loc, eleOff);
    GetFromTuple getFromTuple{symMap, valueInTuple, loc};
    walkCaptureCategories(getFromTuple, converter, *s.value());
  }
}

mlir::Type Fortran::lower::HostAssociations::getArgumentType(
    Fortran::lower::AbstractConverter &converter) {
  if (tupleSymbols.empty())
    return {};
  if (argType)
    return argType;

  // Walk the list of Symbols and create their types. Wrap them in a reference
  // to a tuple.
  mlir::MLIRContext *ctxt = &converter.getMLIRContext();
  llvm::SmallVector<mlir::Type> tupleTys;
  for (const Fortran::semantics::Symbol *sym : tupleSymbols)
    tupleTys.emplace_back(
        walkCaptureCategories(GetTypeInTuple{}, converter, *sym));
  argType = fir::ReferenceType::get(mlir::TupleType::get(ctxt, tupleTys));
  return argType;
}