flang/lib/Lower/HostAssociations.cpp

   1 //===-- HostAssociations.cpp ----------------------------------------------===//
   2 //
   3 // Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
   4 // See https://llvm.org/LICENSE.txt for license information.
   5 // SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
   6 //
   7 //===----------------------------------------------------------------------===//
   8
   9 #include "flang/Lower/HostAssociations.h"
  10 #include "flang/Evaluate/check-expression.h"
  11 #include "flang/Lower/AbstractConverter.h"
  12 #include "flang/Lower/Allocatable.h"
  13 #include "flang/Lower/BoxAnalyzer.h"
  14 #include "flang/Lower/CallInterface.h"
  15 #include "flang/Lower/ConvertType.h"
  16 #include "flang/Lower/ConvertVariable.h"
  17 #include "flang/Lower/PFTBuilder.h"
  18 #include "flang/Lower/SymbolMap.h"
  19 #include "flang/Optimizer/Builder/Character.h"
  20 #include "flang/Optimizer/Builder/FIRBuilder.h"
  21 #include "flang/Optimizer/Builder/Todo.h"
  22 #include "flang/Optimizer/Support/FatalError.h"
  23 #include "flang/Semantics/tools.h"
  24 #include "llvm/ADT/TypeSwitch.h"
  25 #include "llvm/Support/Debug.h"
  26 #include <optional>
  27
  28 #define DEBUG_TYPE "flang-host-assoc"
  29
  30 // Host association inside internal procedures is implemented by allocating an
  31 // mlir tuple (a struct) inside the host containing the addresses and properties
  32 // of variables that are accessed by internal procedures. The address of this
  33 // tuple is passed as an argument by the host when calling internal procedures.
  34 // Internal procedures propagate a reference to this tuple when calling other
  35 // internal procedures of the host.
  36 //
  37 // This file defines how the type of the host tuple is built, how the tuple
  38 // value is created inside the host, and how the host associated variables are
  39 // instantiated inside the internal procedures from the tuple value. The
  40 // CapturedXXX classes define each of these three actions for a specific
  41 // kind of variables by providing a `getType`, a `instantiateHostTuple`, and a
  42 // `getFromTuple` method. These classes are structured as follow:
  43 //
  44 //   class CapturedKindOfVar : public CapturedSymbols<CapturedKindOfVar> {
  45 //     // Return the type of the tuple element for a host associated
  46 //     // variable given its symbol inside the host. This is called when
  47 //     // building function interfaces.
  48 //     static mlir::Type getType();
  49 //     // Build the tuple element value for a host associated variable given its
  50 //     // value inside the host. This is called when lowering the host body.
  51 //     static void instantiateHostTuple();
  52 //     // Instantiate a host variable inside an internal procedure given its
  53 //     // tuple element value. This is called when lowering internal procedure
  54 //     // bodies.
  55 //     static void getFromTuple();
  56 //   };
  57 //
  58 // If a new kind of variable requires ad-hoc handling, a new CapturedXXX class
  59 // should be added to handle it, and `walkCaptureCategories` should be updated
  60 // to dispatch this new kind of variable to this new class.
  61
  62 /// Is \p sym a derived type entity with length parameters ?
  63 static bool isDerivedWithLenParameters(const Fortran::semantics::Symbol &sym) {
  64   if (const auto *declTy = sym.GetType())
  65     if (const auto *derived = declTy->AsDerived())
  66       return Fortran::semantics::CountLenParameters(*derived) != 0;
  67   return false;
  68 }
  69
  70 /// Map the extracted fir::ExtendedValue for a host associated variable inside
  71 /// and internal procedure to its symbol. Generates an hlfir.declare in HLFIR.
  72 static void bindCapturedSymbol(const Fortran::semantics::Symbol &sym,
  73                                fir::ExtendedValue val,
  74                                Fortran::lower::AbstractConverter &converter,
  75                                Fortran::lower::SymMap &symMap) {
  76   if (converter.getLoweringOptions().getLowerToHighLevelFIR())
  77     Fortran::lower::genDeclareSymbol(converter, symMap, sym, val,
  78                                      fir::FortranVariableFlagsEnum::host_assoc);
  79   else
  80     symMap.addSymbol(sym, val);
  81 }
  82
  83 namespace {
  84 /// Struct to be used as argument in walkCaptureCategories when building the
  85 /// tuple element type for a host associated variable.
  86 struct GetTypeInTuple {
  87   /// walkCaptureCategories must return a type.
  88   using Result = mlir::Type;
  89 };
  90
  91 /// Struct to be used as argument in walkCaptureCategories when building the
  92 /// tuple element value for a host associated variable.
  93 struct InstantiateHostTuple {
  94   /// walkCaptureCategories returns nothing.
  95   using Result = void;
  96   /// Value of the variable inside the host procedure.
  97   fir::ExtendedValue hostValue;
  98   /// Address of the tuple element of the variable.
  99   mlir::Value addrInTuple;
 100   mlir::Location loc;
 101 };
 102
 103 /// Struct to be used as argument in walkCaptureCategories when instantiating a
 104 /// host associated variables from its tuple element value.
 105 struct GetFromTuple {
 106   /// walkCaptureCategories returns nothing.
 107   using Result = void;
 108   /// Symbol map inside the internal procedure.
 109   Fortran::lower::SymMap &symMap;
 110   /// Value of the tuple element for the host associated variable.
 111   mlir::Value valueInTuple;
 112   mlir::Location loc;
 113 };
 114
 115 /// Base class that must be inherited with CRTP by classes defining
 116 /// how host association is implemented for a type of symbol.
 117 /// It simply dispatches visit() calls to the implementations according
 118 /// to the argument type.
 119 template <typename SymbolCategory>
 120 class CapturedSymbols {
 121 public:
 122   template <typename T>
 123   static void visit(const T &, Fortran::lower::AbstractConverter &,
 124                     const Fortran::semantics::Symbol &,
 125                     const Fortran::lower::BoxAnalyzer &) {
 126     static_assert(!std::is_same_v<T, T> &&
 127                   "default visit must not be instantiated");
 128   }
 129   static mlir::Type visit(const GetTypeInTuple &,
 130                           Fortran::lower::AbstractConverter &converter,
 131                           const Fortran::semantics::Symbol &sym,
 132                           const Fortran::lower::BoxAnalyzer &) {
 133     return SymbolCategory::getType(converter, sym);
 134   }
 135   static void visit(const InstantiateHostTuple &args,
 136                     Fortran::lower::AbstractConverter &converter,
 137                     const Fortran::semantics::Symbol &sym,
 138                     const Fortran::lower::BoxAnalyzer &) {
 139     return SymbolCategory::instantiateHostTuple(args, converter, sym);
 140   }
 141   static void visit(const GetFromTuple &args,
 142                     Fortran::lower::AbstractConverter &converter,
 143                     const Fortran::semantics::Symbol &sym,
 144                     const Fortran::lower::BoxAnalyzer &ba) {
 145     return SymbolCategory::getFromTuple(args, converter, sym, ba);
 146   }
 147 };
 148
 149 /// Class defining simple scalars are captured in internal procedures.
 150 /// Simple scalars are non character intrinsic scalars. They are captured
 151 /// as `!fir.ref<T>`, for example `!fir.ref<i32>` for `INTEGER*4`.
 152 class CapturedSimpleScalars : public CapturedSymbols<CapturedSimpleScalars> {
 153 public:
 154   static mlir::Type getType(Fortran::lower::AbstractConverter &converter,
 155                             const Fortran::semantics::Symbol &sym) {
 156     return fir::ReferenceType::get(converter.genType(sym));
 157   }
 158
 159   static void instantiateHostTuple(const InstantiateHostTuple &args,
 160                                    Fortran::lower::AbstractConverter &converter,
 161                                    const Fortran::semantics::Symbol &) {
 162     fir::FirOpBuilder &builder = converter.getFirOpBuilder();
 163     mlir::Type typeInTuple = fir::dyn_cast_ptrEleTy(args.addrInTuple.getType());
 164     assert(typeInTuple && "addrInTuple must be an address");
 165     mlir::Value castBox = builder.createConvert(args.loc, typeInTuple,
 166                                                 fir::getBase(args.hostValue));
 167     builder.create<fir::StoreOp>(args.loc, castBox, args.addrInTuple);
 168   }
 169
 170   static void getFromTuple(const GetFromTuple &args,
 171                            Fortran::lower::AbstractConverter &converter,
 172                            const Fortran::semantics::Symbol &sym,
 173                            const Fortran::lower::BoxAnalyzer &) {
 174     bindCapturedSymbol(sym, args.valueInTuple, converter, args.symMap);
 175   }
 176 };
 177
 178 /// Class defining how dummy procedures and procedure pointers
 179 /// are captured in internal procedures.
 180 class CapturedProcedure : public CapturedSymbols<CapturedProcedure> {
 181 public:
 182   static mlir::Type getType(Fortran::lower::AbstractConverter &converter,
 183                             const Fortran::semantics::Symbol &sym) {
 184     if (Fortran::semantics::IsPointer(sym))
 185       TODO(converter.getCurrentLocation(),
 186            "capture procedure pointer in internal procedure");
 187     return Fortran::lower::getDummyProcedureType(sym, converter);
 188   }
 189
 190   static void instantiateHostTuple(const InstantiateHostTuple &args,
 191                                    Fortran::lower::AbstractConverter &converter,
 192                                    const Fortran::semantics::Symbol &) {
 193     fir::FirOpBuilder &builder = converter.getFirOpBuilder();
 194     mlir::Type typeInTuple = fir::dyn_cast_ptrEleTy(args.addrInTuple.getType());
 195     assert(typeInTuple && "addrInTuple must be an address");
 196     mlir::Value castBox = builder.createConvert(args.loc, typeInTuple,
 197                                                 fir::getBase(args.hostValue));
 198     builder.create<fir::StoreOp>(args.loc, castBox, args.addrInTuple);
 199   }
 200
 201   static void getFromTuple(const GetFromTuple &args,
 202                            Fortran::lower::AbstractConverter &converter,
 203                            const Fortran::semantics::Symbol &sym,
 204                            const Fortran::lower::BoxAnalyzer &) {
 205     bindCapturedSymbol(sym, args.valueInTuple, converter, args.symMap);
 206   }
 207 };
 208
 209 /// Class defining how character scalars are captured in internal procedures.
 210 /// Character scalars are passed as !fir.boxchar<kind> in the tuple.
 211 class CapturedCharacterScalars
 212     : public CapturedSymbols<CapturedCharacterScalars> {
 213 public:
 214   // Note: so far, do not specialize constant length characters. They can be
 215   // implemented by only passing the address. This could be done later in
 216   // lowering or a CapturedStaticLenCharacterScalars class could be added here.
 217
 218   static mlir::Type getType(Fortran::lower::AbstractConverter &converter,
 219                             const Fortran::semantics::Symbol &sym) {
 220     fir::KindTy kind =
 221         converter.genType(sym).cast<fir::CharacterType>().getFKind();
 222     return fir::BoxCharType::get(&converter.getMLIRContext(), kind);
 223   }
 224
 225   static void instantiateHostTuple(const InstantiateHostTuple &args,
 226                                    Fortran::lower::AbstractConverter &converter,
 227                                    const Fortran::semantics::Symbol &) {
 228     const fir::CharBoxValue *charBox = args.hostValue.getCharBox();
 229     assert(charBox && "host value must be a fir::CharBoxValue");
 230     fir::FirOpBuilder &builder = converter.getFirOpBuilder();
 231     mlir::Value boxchar = fir::factory::CharacterExprHelper(builder, args.loc)
 232                               .createEmbox(*charBox);
 233     builder.create<fir::StoreOp>(args.loc, boxchar, args.addrInTuple);
 234   }
 235
 236   static void getFromTuple(const GetFromTuple &args,
 237                            Fortran::lower::AbstractConverter &converter,
 238                            const Fortran::semantics::Symbol &sym,
 239                            const Fortran::lower::BoxAnalyzer &) {
 240     fir::factory::CharacterExprHelper charHelp(converter.getFirOpBuilder(),
 241                                                args.loc);
 242     std::pair<mlir::Value, mlir::Value> unboxchar =
 243         charHelp.createUnboxChar(args.valueInTuple);
 244     bindCapturedSymbol(sym,
 245                        fir::CharBoxValue{unboxchar.first, unboxchar.second},
 246                        converter, args.symMap);
 247   }
 248 };
 249
 250 /// Class defining how polymorphic entities are captured in internal procedures.
 251 /// Polymorphic entities are always boxed as a fir.class box.
 252 class CapturedPolymorphic : public CapturedSymbols<CapturedPolymorphic> {
 253 public:
 254   static mlir::Type getType(Fortran::lower::AbstractConverter &converter,
 255                             const Fortran::semantics::Symbol &sym) {
 256     return converter.genType(sym);
 257   }
 258   static void instantiateHostTuple(const InstantiateHostTuple &args,
 259                                    Fortran::lower::AbstractConverter &converter,
 260                                    const Fortran::semantics::Symbol &) {
 261     fir::FirOpBuilder &builder = converter.getFirOpBuilder();
 262     mlir::Type typeInTuple = fir::dyn_cast_ptrEleTy(args.addrInTuple.getType());
 263     assert(typeInTuple && "addrInTuple must be an address");
 264     mlir::Value castBox = builder.createConvert(args.loc, typeInTuple,
 265                                                 fir::getBase(args.hostValue));
 266     builder.create<fir::StoreOp>(args.loc, castBox, args.addrInTuple);
 267   }
 268   static void getFromTuple(const GetFromTuple &args,
 269                            Fortran::lower::AbstractConverter &converter,
 270                            const Fortran::semantics::Symbol &sym,
 271                            const Fortran::lower::BoxAnalyzer &ba) {
 272     bindCapturedSymbol(sym, args.valueInTuple, converter, args.symMap);
 273   }
 274 };
 275
 276 /// Class defining how allocatable and pointers entities are captured in
 277 /// internal procedures. Allocatable and pointers are simply captured by placing
 278 /// their !fir.ref<fir.box<>> address in the host tuple.
 279 class CapturedAllocatableAndPointer
 280     : public CapturedSymbols<CapturedAllocatableAndPointer> {
 281 public:
 282   static mlir::Type getType(Fortran::lower::AbstractConverter &converter,
 283                             const Fortran::semantics::Symbol &sym) {
 284     return fir::ReferenceType::get(converter.genType(sym));
 285   }
 286   static void instantiateHostTuple(const InstantiateHostTuple &args,
 287                                    Fortran::lower::AbstractConverter &converter,
 288                                    const Fortran::semantics::Symbol &) {
 289     assert(args.hostValue.getBoxOf<fir::MutableBoxValue>() &&
 290            "host value must be a fir::MutableBoxValue");
 291     fir::FirOpBuilder &builder = converter.getFirOpBuilder();
 292     mlir::Type typeInTuple = fir::dyn_cast_ptrEleTy(args.addrInTuple.getType());
 293     assert(typeInTuple && "addrInTuple must be an address");
 294     mlir::Value castBox = builder.createConvert(args.loc, typeInTuple,
 295                                                 fir::getBase(args.hostValue));
 296     builder.create<fir::StoreOp>(args.loc, castBox, args.addrInTuple);
 297   }
 298   static void getFromTuple(const GetFromTuple &args,
 299                            Fortran::lower::AbstractConverter &converter,
 300                            const Fortran::semantics::Symbol &sym,
 301                            const Fortran::lower::BoxAnalyzer &ba) {
 302     fir::FirOpBuilder &builder = converter.getFirOpBuilder();
 303     mlir::Location loc = args.loc;
 304     // Non deferred type parameters impact the semantics of some statements
 305     // where allocatables/pointer can appear. For instance, assignment to a
 306     // scalar character allocatable with has a different semantics in F2003 and
 307     // later if the length is non deferred vs when it is deferred. So it is
 308     // important to keep track of the non deferred parameters here.
 309     llvm::SmallVector<mlir::Value> nonDeferredLenParams;
 310     if (ba.isChar()) {
 311       mlir::IndexType idxTy = builder.getIndexType();
 312       if (std::optional<int64_t> len = ba.getCharLenConst()) {
 313         nonDeferredLenParams.push_back(
 314             builder.createIntegerConstant(loc, idxTy, *len));
 315       } else if (Fortran::semantics::IsAssumedLengthCharacter(sym) ||
 316                  ba.getCharLenExpr()) {
 317         nonDeferredLenParams.push_back(
 318             Fortran::lower::getAssumedCharAllocatableOrPointerLen(
 319                 builder, loc, sym, args.valueInTuple));
 320       }
 321     } else if (isDerivedWithLenParameters(sym)) {
 322       TODO(loc, "host associated derived type allocatable or pointer with "
 323                 "length parameters");
 324     }
 325     bindCapturedSymbol(
 326         sym, fir::MutableBoxValue(args.valueInTuple, nonDeferredLenParams, {}),
 327         converter, args.symMap);
 328   }
 329 };
 330
 331 /// Class defining how arrays are captured inside internal procedures.
 332 /// Array are captured via a `fir.box<fir.array<T>>` descriptor that belongs to
 333 /// the host tuple. This allows capturing lower bounds, which can be done by
 334 /// providing a ShapeShiftOp argument to the EmboxOp.
 335 class CapturedArrays : public CapturedSymbols<CapturedArrays> {
 336
 337   // Note: Constant shape arrays are not specialized (their base address would
 338   // be sufficient information inside the tuple). They could be specialized in
 339   // a later FIR pass, or a CapturedStaticShapeArrays could be added to deal
 340   // with them here.
 341 public:
 342   static mlir::Type getType(Fortran::lower::AbstractConverter &converter,
 343                             const Fortran::semantics::Symbol &sym) {
 344     mlir::Type type = converter.genType(sym);
 345     assert(type.isa<fir::SequenceType>() && "must be a sequence type");
 346     return fir::BoxType::get(type);
 347   }
 348
 349   static void instantiateHostTuple(const InstantiateHostTuple &args,
 350                                    Fortran::lower::AbstractConverter &converter,
 351                                    const Fortran::semantics::Symbol &sym) {
 352     fir::FirOpBuilder &builder = converter.getFirOpBuilder();
 353     mlir::Location loc = args.loc;
 354     fir::MutableBoxValue boxInTuple(args.addrInTuple, {}, {});
 355     if (args.hostValue.getBoxOf<fir::BoxValue>() &&
 356         Fortran::semantics::IsOptional(sym)) {
 357       // The assumed shape optional case need some care because it is illegal to
 358       // read the incoming box if it is absent (this would cause segfaults).
 359       // Pointer association requires reading the target box, so it can only be
 360       // done on present optional. For absent optionals, simply create a
 361       // disassociated pointer (it is illegal to inquire about lower bounds or
 362       // lengths of optional according to 15.5.2.12 3 (9) and 10.1.11 2 (7)b).
 363       auto isPresent = builder.create<fir::IsPresentOp>(
 364           loc, builder.getI1Type(), fir::getBase(args.hostValue));
 365       builder.genIfThenElse(loc, isPresent)
 366           .genThen([&]() {
 367             fir::factory::associateMutableBox(builder, loc, boxInTuple,
 368                                               args.hostValue,
 369                                               /*lbounds=*/std::nullopt);
 370           })
 371           .genElse([&]() {
 372             fir::factory::disassociateMutableBox(builder, loc, boxInTuple);
 373           })
 374           .end();
 375     } else {
 376       fir::factory::associateMutableBox(
 377           builder, loc, boxInTuple, args.hostValue, /*lbounds=*/std::nullopt);
 378     }
 379   }
 380
 381   static void getFromTuple(const GetFromTuple &args,
 382                            Fortran::lower::AbstractConverter &converter,
 383                            const Fortran::semantics::Symbol &sym,
 384                            const Fortran::lower::BoxAnalyzer &ba) {
 385     fir::FirOpBuilder &builder = converter.getFirOpBuilder();
 386     mlir::Location loc = args.loc;
 387     mlir::Value box = args.valueInTuple;
 388     mlir::IndexType idxTy = builder.getIndexType();
 389     llvm::SmallVector<mlir::Value> lbounds;
 390     if (!ba.lboundIsAllOnes()) {
 391       if (ba.isStaticArray()) {
 392         for (std::int64_t lb : ba.staticLBound())
 393           lbounds.emplace_back(builder.createIntegerConstant(loc, idxTy, lb));
 394       } else {
 395         // Cannot re-evaluate specification expressions here.
 396         // Operands values may have changed. Get value from fir.box
 397         const unsigned rank = sym.Rank();
 398         for (unsigned dim = 0; dim < rank; ++dim) {
 399           mlir::Value dimVal = builder.createIntegerConstant(loc, idxTy, dim);
 400           auto dims = builder.create<fir::BoxDimsOp>(loc, idxTy, idxTy, idxTy,
 401                                                      box, dimVal);
 402           lbounds.emplace_back(dims.getResult(0));
 403         }
 404       }
 405     }
 406
 407     if (canReadCapturedBoxValue(converter, sym)) {
 408       fir::BoxValue boxValue(box, lbounds, /*explicitParams=*/std::nullopt);
 409       bindCapturedSymbol(sym,
 410                          fir::factory::readBoxValue(builder, loc, boxValue),
 411                          converter, args.symMap);
 412     } else {
 413       // Keep variable as a fir.box.
 414       // If this is an optional that is absent, the fir.box needs to be an
 415       // AbsentOp result, otherwise it will not work properly with IsPresentOp
 416       // (absent boxes are null descriptor addresses, not descriptors containing
 417       // a null base address).
 418       if (Fortran::semantics::IsOptional(sym)) {
 419         auto boxTy = box.getType().cast<fir::BoxType>();
 420         auto eleTy = boxTy.getEleTy();
 421         if (!fir::isa_ref_type(eleTy))
 422           eleTy = builder.getRefType(eleTy);
 423         auto addr = builder.create<fir::BoxAddrOp>(loc, eleTy, box);
 424         mlir::Value isPresent = builder.genIsNotNullAddr(loc, addr);
 425         auto absentBox = builder.create<fir::AbsentOp>(loc, boxTy);
 426         box = builder.create<mlir::arith::SelectOp>(loc, isPresent, box,
 427                                                     absentBox);
 428       }
 429       fir::BoxValue boxValue(box, lbounds, /*explicitParams=*/std::nullopt);
 430       bindCapturedSymbol(sym, boxValue, converter, args.symMap);
 431     }
 432   }
 433
 434 private:
 435   /// Can the fir.box from the host link be read into simpler values ?
 436   /// Later, without the symbol information, it might not be possible
 437   /// to tell if the fir::BoxValue from the host link is contiguous.
 438   static bool
 439   canReadCapturedBoxValue(Fortran::lower::AbstractConverter &converter,
 440                           const Fortran::semantics::Symbol &sym) {
 441     bool isScalarOrContiguous =
 442         sym.Rank() == 0 || Fortran::evaluate::IsSimplyContiguous(
 443                                Fortran::evaluate::AsGenericExpr(sym).value(),
 444                                converter.getFoldingContext());
 445     const Fortran::semantics::DeclTypeSpec *type = sym.GetType();
 446     bool isPolymorphic = type && type->IsPolymorphic();
 447     return isScalarOrContiguous && !isPolymorphic &&
 448            !isDerivedWithLenParameters(sym);
 449   }
 450 };
 451 } // namespace
 452
 453 /// Dispatch \p visitor to the CapturedSymbols which is handling how host
 454 /// association is implemented for this kind of symbols. This ensures the same
 455 /// dispatch decision is taken when building the tuple type, when creating the
 456 /// tuple, and when instantiating host associated variables from it.
 457 template <typename T>
 458 static typename T::Result
 459 walkCaptureCategories(T visitor, Fortran::lower::AbstractConverter &converter,
 460                       const Fortran::semantics::Symbol &sym) {
 461   if (isDerivedWithLenParameters(sym))
 462     // Should be boxed.
 463     TODO(converter.genLocation(sym.name()),
 464          "host associated derived type with length parameters");
 465   Fortran::lower::BoxAnalyzer ba;
 466   // Do not analyze procedures, they may be subroutines with no types that would
 467   // crash the analysis.
 468   if (Fortran::semantics::IsProcedure(sym))
 469     return CapturedProcedure::visit(visitor, converter, sym, ba);
 470   ba.analyze(sym);
 471   if (Fortran::semantics::IsAllocatableOrPointer(sym))
 472     return CapturedAllocatableAndPointer::visit(visitor, converter, sym, ba);
 473   if (Fortran::semantics::IsPolymorphic(sym)) {
 474     if (ba.isArray() && !ba.lboundIsAllOnes())
 475       TODO(converter.genLocation(sym.name()),
 476            "polymorphic array with non default lower bound");
 477     return CapturedPolymorphic::visit(visitor, converter, sym, ba);
 478   }
 479   if (ba.isArray())
 480     return CapturedArrays::visit(visitor, converter, sym, ba);
 481   if (ba.isChar())
 482     return CapturedCharacterScalars::visit(visitor, converter, sym, ba);
 483   assert(ba.isTrivial() && "must be trivial scalar");
 484   return CapturedSimpleScalars::visit(visitor, converter, sym, ba);
 485 }
 486
 487 // `t` should be the result of getArgumentType, which has a type of
 488 // `!fir.ref<tuple<...>>`.
 489 static mlir::TupleType unwrapTupleTy(mlir::Type t) {
 490   return fir::dyn_cast_ptrEleTy(t).cast<mlir::TupleType>();
 491 }
 492
 493 static mlir::Value genTupleCoor(fir::FirOpBuilder &builder, mlir::Location loc,
 494                                 mlir::Type varTy, mlir::Value tupleArg,
 495                                 mlir::Value offset) {
 496   // fir.ref<fir.ref> and fir.ptr<fir.ref> are forbidden. Use
 497   // fir.llvm_ptr if needed.
 498   auto ty = varTy.isa<fir::ReferenceType>()
 499                 ? mlir::Type(fir::LLVMPointerType::get(varTy))
 500                 : mlir::Type(builder.getRefType(varTy));
 501   return builder.create<fir::CoordinateOp>(loc, ty, tupleArg, offset);
 502 }
 503
 504 void Fortran::lower::HostAssociations::addSymbolsToBind(
 505     const llvm::SetVector<const Fortran::semantics::Symbol *> &symbols,
 506     const Fortran::semantics::Scope &hostScope) {
 507   assert(tupleSymbols.empty() && globalSymbols.empty() &&
 508          "must be initially empty");
 509   this->hostScope = &hostScope;
 510   for (const auto *s : symbols)
 511     if (Fortran::lower::symbolIsGlobal(*s)) {
 512       // The ultimate symbol is stored here so that global symbols from the
 513       // host scope can later be searched in this set.
 514       globalSymbols.insert(&s->GetUltimate());
 515     } else {
 516       tupleSymbols.insert(s);
 517     }
 518 }
 519
 520 void Fortran::lower::HostAssociations::hostProcedureBindings(
 521     Fortran::lower::AbstractConverter &converter,
 522     Fortran::lower::SymMap &symMap) {
 523   if (tupleSymbols.empty())
 524     return;
 525
 526   // Create the tuple variable.
 527   mlir::TupleType tupTy = unwrapTupleTy(getArgumentType(converter));
 528   fir::FirOpBuilder &builder = converter.getFirOpBuilder();
 529   mlir::Location loc = converter.getCurrentLocation();
 530   auto hostTuple = builder.create<fir::AllocaOp>(loc, tupTy);
 531   mlir::IntegerType offTy = builder.getIntegerType(32);
 532
 533   // Walk the list of tupleSymbols and update the pointers in the tuple.
 534   for (auto s : llvm::enumerate(tupleSymbols)) {
 535     auto indexInTuple = s.index();
 536     mlir::Value off = builder.createIntegerConstant(loc, offTy, indexInTuple);
 537     mlir::Type varTy = tupTy.getType(indexInTuple);
 538     mlir::Value eleOff = genTupleCoor(builder, loc, varTy, hostTuple, off);
 539     InstantiateHostTuple instantiateHostTuple{
 540         converter.getSymbolExtendedValue(*s.value(), &symMap), eleOff, loc};
 541     walkCaptureCategories(instantiateHostTuple, converter, *s.value());
 542   }
 543
 544   converter.bindHostAssocTuple(hostTuple);
 545 }
 546
 547 void Fortran::lower::HostAssociations::internalProcedureBindings(
 548     Fortran::lower::AbstractConverter &converter,
 549     Fortran::lower::SymMap &symMap) {
 550   if (!globalSymbols.empty()) {
 551     assert(hostScope && "host scope must have been set");
 552     Fortran::lower::AggregateStoreMap storeMap;
 553     // The host scope variable list is required to deal with host variables
 554     // that are equivalenced and requires instantiating the right global
 555     // AggregateStore.
 556     for (auto &hostVariable : pft::getScopeVariableList(*hostScope))
 557       if ((hostVariable.isAggregateStore() && hostVariable.isGlobal()) ||
 558           (hostVariable.hasSymbol() &&
 559            globalSymbols.contains(&hostVariable.getSymbol().GetUltimate())))
 560         Fortran::lower::instantiateVariable(converter, hostVariable, symMap,
 561                                             storeMap);
 562   }
 563   if (tupleSymbols.empty())
 564     return;
 565
 566   // Find the argument with the tuple type. The argument ought to be appended.
 567   fir::FirOpBuilder &builder = converter.getFirOpBuilder();
 568   mlir::Type argTy = getArgumentType(converter);
 569   mlir::TupleType tupTy = unwrapTupleTy(argTy);
 570   mlir::Location loc = converter.getCurrentLocation();
 571   mlir::func::FuncOp func = builder.getFunction();
 572   mlir::Value tupleArg;
 573   for (auto [ty, arg] : llvm::reverse(llvm::zip(
 574            func.getFunctionType().getInputs(), func.front().getArguments())))
 575     if (ty == argTy) {
 576       tupleArg = arg;
 577       break;
 578     }
 579   if (!tupleArg)
 580     fir::emitFatalError(loc, "no host association argument found");
 581
 582   converter.bindHostAssocTuple(tupleArg);
 583
 584   mlir::IntegerType offTy = builder.getIntegerType(32);
 585
 586   // Walk the list and add the bindings to the symbol table.
 587   for (auto s : llvm::enumerate(tupleSymbols)) {
 588     mlir::Value off = builder.createIntegerConstant(loc, offTy, s.index());
 589     mlir::Type varTy = tupTy.getType(s.index());
 590     mlir::Value eleOff = genTupleCoor(builder, loc, varTy, tupleArg, off);
 591     mlir::Value valueInTuple = builder.create<fir::LoadOp>(loc, eleOff);
 592     GetFromTuple getFromTuple{symMap, valueInTuple, loc};
 593     walkCaptureCategories(getFromTuple, converter, *s.value());
 594   }
 595 }
 596
 597 mlir::Type Fortran::lower::HostAssociations::getArgumentType(
 598     Fortran::lower::AbstractConverter &converter) {
 599   if (tupleSymbols.empty())
 600     return {};
 601   if (argType)
 602     return argType;
 603
 604   // Walk the list of Symbols and create their types. Wrap them in a reference
 605   // to a tuple.
 606   mlir::MLIRContext *ctxt = &converter.getMLIRContext();
 607   llvm::SmallVector<mlir::Type> tupleTys;
 608   for (const Fortran::semantics::Symbol *sym : tupleSymbols)
 609     tupleTys.emplace_back(
 610         walkCaptureCategories(GetTypeInTuple{}, converter, *sym));
 611   argType = fir::ReferenceType::get(mlir::TupleType::get(ctxt, tupleTys));
 612   return argType;
 613 }