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