diff --git a/flang/lib/Lower/HostAssociations.cpp b/flang/lib/Lower/HostAssociations.cpp --- a/flang/lib/Lower/HostAssociations.cpp +++ b/flang/lib/Lower/HostAssociations.cpp @@ -59,6 +59,30 @@ // 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 { @@ -146,10 +170,10 @@ } 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); } }; @@ -177,10 +201,10 @@ } 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); } }; @@ -223,14 +247,6 @@ } }; -/// 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 { @@ -253,7 +269,7 @@ 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); } }; @@ -306,8 +322,9 @@ 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); } }; @@ -389,8 +406,9 @@ 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 @@ -409,7 +427,7 @@ absentBox); } fir::BoxValue boxValue(box, lbounds, /*explicitParams=*/std::nullopt); - args.symMap.addSymbol(sym, boxValue); + bindCapturedSymbol(sym, boxValue, converter, args.symMap); } } @@ -430,13 +448,14 @@ !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::Result +static typename T::Result walkCaptureCategories(T visitor, Fortran::lower::AbstractConverter &converter, const Fortran::semantics::Symbol &sym) { if (isDerivedWithLenParameters(sym)) diff --git a/flang/test/Lower/HLFIR/internal-procedures.f90 b/flang/test/Lower/HLFIR/internal-procedures.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Lower/HLFIR/internal-procedures.f90 @@ -0,0 +1,38 @@ +! 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>>> {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>>>, i32) -> !fir.ref>> +! CHECK: %[[VAL_3:.*]] = fir.load %[[VAL_2]] : !fir.ref>> +! CHECK: %[[VAL_4:.*]] = fir.box_addr %[[VAL_3]] : (!fir.box>) -> !fir.ref> +! CHECK: %[[VAL_5:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_6:.*]]:3 = fir.box_dims %[[VAL_3]], %[[VAL_5]] : (!fir.box>, 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.shape<1>) -> (!fir.box>, !fir.ref>) + +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>>> {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>>>, i32) -> !fir.ref>> +! CHECK: %[[VAL_3:.*]] = fir.load %[[VAL_2]] : !fir.ref>> +! CHECK: %[[VAL_4:.*]] = arith.constant 0 : index +! CHECK: %[[VAL_5:.*]]:3 = fir.box_dims %[[VAL_3]], %[[VAL_4]] : (!fir.box>, 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.shift<1>) -> (!fir.box>, !fir.box>)