[flang][hlfir] Emit hlfir.declare inside internal procedures

[jeanPerier]

Summary

Captured variables inside internal procedure do not go though
Fortran::lower::instantiateVar because the specification expressions
should no be lowered again, and instead, all the information must be
taken from the host link argument.

There is nothing very special to do for HLFIR, but the hlfir.declare
should be emitted for the instantiated captured variable and mapped
to the symbol.

[clementval]

LGTM

flang/lib/Lower/HostAssociations.cpp

 //     // 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()) {
+    // TODO: add an indication that this is a host variable in the declare to
+    // allow alias analysis to detect this case.
+    Fortran::lower::genDeclareSymbol(converter, symMap, sym, val);
+  } 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
static void instantiateHostTuple(const InstantiateHostTuple &args,
     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 &,
+                           Fortran::lower::AbstractConverter &converter,
                            const Fortran::semantics::Symbol &sym,
                            const Fortran::lower::BoxAnalyzer &) {
-    args.symMap.addSymbol(sym, args.valueInTuple);
+    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,
static void instantiateHostTuple(const InstantiateHostTuple &args,
     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 &,
+                           Fortran::lower::AbstractConverter &converter,
                            const Fortran::semantics::Symbol &sym,
                            const Fortran::lower::BoxAnalyzer &) {
-    args.symMap.addSymbol(sym, args.valueInTuple);
+    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:
static void getFromTuple(const GetFromTuple &args,
     fir::factory::CharacterExprHelper charHelp(converter.getFirOpBuilder(),
                                                args.loc);
     std::pair<mlir::Value, mlir::Value> unboxchar =
         charHelp.createUnboxChar(args.valueInTuple);
     args.symMap.addCharSymbol(sym, unboxchar.first, unboxchar.second);
   }
 };
 
-/// 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;
-}
-
 /// Class defining how polymorphic entities are captured in internal procedures.
 /// Polymorphic entities are always boxed as a fir.class box.
 class CapturedPolymorphic : public CapturedSymbols<CapturedPolymorphic> {
 public:
   static mlir::Type getType(Fortran::lower::AbstractConverter &converter,
                             const Fortran::semantics::Symbol &sym) {
     return fir::ClassType::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 &ba) {
-    args.symMap.addSymbol(sym, args.valueInTuple);
+    bindCapturedSymbol(sym, args.valueInTuple, 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> {
if (ba.isChar()) {
         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");
     }
-    args.symMap.addSymbol(
-        sym, fir::MutableBoxValue(args.valueInTuple, nonDeferredLenParams, {}));
+    bindCapturedSymbol(
+        sym, fir::MutableBoxValue(args.valueInTuple, nonDeferredLenParams, {}),
+        converter, args.symMap);
   }
 };
 
 /// Class defining how arrays 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> {
if (!ba.lboundIsAllOnes()) {
                                                      box, dimVal);
           lbounds.emplace_back(dims.getResult(0));
         }
       }
     }
 
     if (canReadCapturedBoxValue(converter, sym)) {
       fir::BoxValue boxValue(box, lbounds, /*explicitParams=*/std::nullopt);
-      args.symMap.addSymbol(sym,
-                            fir::factory::readBoxValue(builder, loc, boxValue));
+      bindCapturedSymbol(sym,
+                         fir::factory::readBoxValue(builder, loc, boxValue),
+                         converter, args.symMap);
     } else {
       // Keep variable as a fir.box.
       // 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 = box.getType().cast<fir::BoxType>();
         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);
-      args.symMap.addSymbol(sym, boxValue);
+      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);
   }
 };
+} // 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>
-typename T::Result
+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

flang/test/Lower/HLFIR/internal-procedures.f90

+! Test captured variables instantiation inside internal procedures
+! when lowering to HLFIR.
+! RUN: bbc -emit-fir -hlfir -o - %s | FileCheck %s
+subroutine test_explicit_shape_array(x, n)
+  integer(8) :: n
+  real :: x(n)
+contains
+subroutine internal
+  call takes_array(x)
+end subroutine
+end subroutine
+! CHECK-LABEL: func.func @_QFtest_explicit_shape_arrayPinternal(
+! CHECK-SAME:  %[[VAL_0:.*]]: !fir.ref<tuple<!fir.box<!fir.array<?xf32>>>> {fir.host_assoc}) attributes {fir.internal_proc} {
+! CHECK:  %[[VAL_1:.*]] = arith.constant 0 : i32
+! CHECK:  %[[VAL_2:.*]] = fir.coordinate_of %[[VAL_0]], %[[VAL_1]] : (!fir.ref<tuple<!fir.box<!fir.array<?xf32>>>>, i32) -> !fir.ref<!fir.box<!fir.array<?xf32>>>
+! CHECK:  %[[VAL_3:.*]] = fir.load %[[VAL_2]] : !fir.ref<!fir.box<!fir.array<?xf32>>>
+! CHECK:  %[[VAL_4:.*]] = fir.box_addr %[[VAL_3]] : (!fir.box<!fir.array<?xf32>>) -> !fir.ref<!fir.array<?xf32>>
+! CHECK:  %[[VAL_5:.*]] = arith.constant 0 : index
+! CHECK:  %[[VAL_6:.*]]:3 = fir.box_dims %[[VAL_3]], %[[VAL_5]] : (!fir.box<!fir.array<?xf32>>, index) -> (index, index, index)
+! CHECK:  %[[VAL_7:.*]] = fir.shape %[[VAL_6]]#1 : (index) -> !fir.shape<1>
+! CHECK:  %[[VAL_8:.*]]:2 = hlfir.declare %[[VAL_4]](%[[VAL_7]]) {uniq_name = "_QFtest_explicit_shape_arrayEx"} : (!fir.ref<!fir.array<?xf32>>, !fir.shape<1>) -> (!fir.box<!fir.array<?xf32>>, !fir.ref<!fir.array<?xf32>>)
+
+subroutine test_assumed_shape(x)
+  real :: x(:)
+contains
+subroutine internal
+  call takes_array(x)
+end subroutine
+end subroutine
+! CHECK-LABEL: func.func @_QFtest_assumed_shapePinternal(
+! CHECK-SAME:  %[[VAL_0:.*]]: !fir.ref<tuple<!fir.box<!fir.array<?xf32>>>> {fir.host_assoc}) attributes {fir.internal_proc} {
+! CHECK:  %[[VAL_1:.*]] = arith.constant 0 : i32
+! CHECK:  %[[VAL_2:.*]] = fir.coordinate_of %[[VAL_0]], %[[VAL_1]] : (!fir.ref<tuple<!fir.box<!fir.array<?xf32>>>>, i32) -> !fir.ref<!fir.box<!fir.array<?xf32>>>
+! CHECK:  %[[VAL_3:.*]] = fir.load %[[VAL_2]] : !fir.ref<!fir.box<!fir.array<?xf32>>>
+! CHECK:  %[[VAL_4:.*]] = arith.constant 0 : index
+! CHECK:  %[[VAL_5:.*]]:3 = fir.box_dims %[[VAL_3]], %[[VAL_4]] : (!fir.box<!fir.array<?xf32>>, index) -> (index, index, index)
+! CHECK:  %[[VAL_6:.*]] = fir.shift %[[VAL_5]]#0 : (index) -> !fir.shift<1>
+! CHECK:  %[[VAL_7:.*]]:2 = hlfir.declare %[[VAL_3]](%[[VAL_6]]) {uniq_name = "_QFtest_assumed_shapeEx"} : (!fir.box<!fir.array<?xf32>>, !fir.shift<1>) -> (!fir.box<!fir.array<?xf32>>, !fir.box<!fir.array<?xf32>>)