[flang] Capture result interface of functions called in internal procedures

[clementval]

Summary

Character and array results are allocated on the caller side. This
require evaluating the result interface on the call site. When calling
such functions inside an internal procedure, it is possible that the
interface is defined in the host, in which case the lengths/bounds of
the function results must be captured so that they are available in
the internal function to emit the call.

To handle this case, extend the PFT symbol visit to visit the bounds and length
parameters of functions called in the internal procedure parse tree.

This patch is part of the upstreaming effort from fir-dev branch.

Co-authored-by: Jean Perier <[e-mail]>

flang/lib/Lower/PFTBuilder.cpp

struct SymbolVisitor {
   }
 
   bool Pre(const Fortran::parser::Name &name) {
     if (const semantics::Symbol *symbol = name.symbol)
       visitSymbol(*symbol);
     return false;
   }
 
-  void visitExpr(const Fortran::lower::SomeExpr &expr) {
+  template <typename T>
+  void visitExpr(const Fortran::evaluate::Expr<T> &expr) {
     for (const semantics::Symbol &symbol :
          Fortran::evaluate::CollectSymbols(expr))
       visitSymbol(symbol);
   }
 
   void visitSymbol(const Fortran::semantics::Symbol &symbol) {
     callBack(symbol);
-    // Visit statement function body since it will be inlined in lowering.
+    // - Visit statement function body since it will be inlined in lowering.
+    // - Visit function results specification expressions because allocations
+    //   happens on the caller side.
     if (const auto *subprogramDetails =
-            symbol.detailsIf<Fortran::semantics::SubprogramDetails>())
-      if (const auto &maybeExpr = subprogramDetails->stmtFunction())
+            symbol.detailsIf<Fortran::semantics::SubprogramDetails>()) {
+      if (const auto &maybeExpr = subprogramDetails->stmtFunction()) {
         visitExpr(*maybeExpr);
+      } else {
+        if (subprogramDetails->isFunction()) {
+          // Visit result extents expressions that are explicit.
+          const Fortran::semantics::Symbol &result =
+              subprogramDetails->result();
+          if (const auto *objectDetails =
+                  result.detailsIf<Fortran::semantics::ObjectEntityDetails>())
+            if (objectDetails->shape().IsExplicitShape())
+              for (const Fortran::semantics::ShapeSpec &shapeSpec :
+                   objectDetails->shape()) {
+                visitExpr(shapeSpec.lbound().GetExplicit().value());
+                visitExpr(shapeSpec.ubound().GetExplicit().value());
+              }
+        }
+      }
+    }
+    if (Fortran::semantics::IsProcedure(symbol)) {
+      if (auto dynamicType = Fortran::evaluate::DynamicType::From(symbol)) {
+        // Visit result length specification expressions that are explicit.
+        if (dynamicType->category() ==
+            Fortran::common::TypeCategory::Character) {
+          if (std::optional<Fortran::evaluate::ExtentExpr> length =
+                  dynamicType->GetCharLength())
+            visitExpr(*length);
+        } else if (dynamicType->category() == common::TypeCategory::Derived) {
+          const Fortran::semantics::DerivedTypeSpec &derivedTypeSpec =
+              dynamicType->GetDerivedTypeSpec();
+          for (const auto &[_, param] : derivedTypeSpec.parameters())
+            if (const Fortran::semantics::MaybeIntExpr &expr =
+                    param.GetExplicit())
+              visitExpr(expr.value());
+        }
+      }
+    }
   }
 
   template <typename A>
   constexpr void Post(const A &) {}
 
   const std::function<void(const Fortran::semantics::Symbol &)> &callBack;
 };
 } // namespace

flang/test/Lower/host-associated-functions.f90

+! RUN: bbc -emit-fir %s -o - | FileCheck %s
+
+! Test calling functions whose result interface is evaluated on the call site
+! and where the calls are located in an internal procedure while the
+! interface is defined in the host procedure.
+
+! CHECK-LABEL: func @_QPcapture_char_func_dummy(
+! CHECK-SAME:  %[[VAL_0:.*]]: tuple<!fir.boxproc<() -> ()>, i64> {fir.char_proc},
+! CHECK-SAME:  %[[VAL_1:.*]]: !fir.ref<i32> {fir.bindc_name = "n"}) {
+subroutine capture_char_func_dummy(char_func_dummy, n)
+  character(n),external :: char_func_dummy
+  ! CHECK:  %[[VAL_2:.*]] = fir.alloca tuple<tuple<!fir.boxproc<() -> ()>, i64>, !fir.ref<i32>>
+  ! CHECK:  %[[VAL_3:.*]] = arith.constant 0 : i32
+  ! CHECK:  %[[VAL_4:.*]] = fir.coordinate_of %[[VAL_2]], %[[VAL_3]] : (!fir.ref<tuple<tuple<!fir.boxproc<() -> ()>, i64>, !fir.ref<i32>>>, i32) -> !fir.ref<tuple<!fir.boxproc<() -> ()>, i64>>
+  ! CHECK:  fir.store %[[VAL_0]] to %[[VAL_4]] : !fir.ref<tuple<!fir.boxproc<() -> ()>, i64>>
+  ! CHECK:  %[[VAL_5:.*]] = arith.constant 1 : i32
+  ! CHECK:  %[[VAL_6:.*]] = fir.coordinate_of %[[VAL_2]], %[[VAL_5]] : (!fir.ref<tuple<tuple<!fir.boxproc<() -> ()>, i64>, !fir.ref<i32>>>, i32) -> !fir.llvm_ptr<!fir.ref<i32>>
+  ! CHECK:  fir.store %[[VAL_1]] to %[[VAL_6]] : !fir.llvm_ptr<!fir.ref<i32>>
+  ! CHECK:  fir.call @_QFcapture_char_func_dummyPinternal(%[[VAL_2]]) : (!fir.ref<tuple<tuple<!fir.boxproc<() -> ()>, i64>, !fir.ref<i32>>>) -> ()
+  call internal()
+contains
+  ! CHECK-LABEL: func @_QFcapture_char_func_dummyPinternal(
+  ! CHECK-SAME:  %[[VAL_0:.*]]: !fir.ref<tuple<tuple<!fir.boxproc<() -> ()>, i64>, !fir.ref<i32>>> {fir.host_assoc}) {
+  subroutine internal()
+  ! CHECK:  %[[VAL_1:.*]] = arith.constant 0 : i32
+  ! CHECK:  %[[VAL_2:.*]] = fir.coordinate_of %[[VAL_0]], %[[VAL_1]] : (!fir.ref<tuple<tuple<!fir.boxproc<() -> ()>, i64>, !fir.ref<i32>>>, i32) -> !fir.ref<tuple<!fir.boxproc<() -> ()>, i64>>
+  ! CHECK:  %[[VAL_3:.*]] = fir.load %[[VAL_2]] : !fir.ref<tuple<!fir.boxproc<() -> ()>, i64>>
+  ! CHECK:  %[[VAL_4:.*]] = arith.constant 1 : i32
+  ! CHECK:  %[[VAL_5:.*]] = fir.coordinate_of %[[VAL_0]], %[[VAL_4]] : (!fir.ref<tuple<tuple<!fir.boxproc<() -> ()>, i64>, !fir.ref<i32>>>, i32) -> !fir.llvm_ptr<!fir.ref<i32>>
+  ! CHECK:  %[[VAL_6:.*]] = fir.load %[[VAL_5]] : !fir.llvm_ptr<!fir.ref<i32>>
+  ! CHECK:  %[[VAL_12:.*]] = fir.extract_value %[[VAL_3]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>) -> !fir.boxproc<() -> ()>
+  ! CHECK:  %[[VAL_13:.*]] = fir.box_addr %[[VAL_12]] : (!fir.boxproc<() -> ()>) -> (() -> ())
+  ! CHECK:  %[[VAL_14:.*]] = fir.load %[[VAL_6]] : !fir.ref<i32>
+  ! CHECK:  %[[VAL_15:.*]] = fir.convert %[[VAL_14]] : (i32) -> i64
+  ! CHECK:  %[[VAL_16:.*]] = fir.convert %[[VAL_15]] : (i64) -> index
+  ! CHECK:  %[[VAL_17:.*]] = fir.call @llvm.stacksave() : () -> !fir.ref<i8>
+  ! CHECK:  %[[VAL_18:.*]] = fir.alloca !fir.char<1,?>(%[[VAL_16]] : index) {bindc_name = ".result"}
+  ! CHECK:  %[[VAL_19:.*]] = fir.convert %[[VAL_13]] : (() -> ()) -> ((!fir.ref<!fir.char<1,?>>, index) -> !fir.boxchar<1>)
+  ! CHECK:  %[[VAL_20:.*]] = fir.call %[[VAL_19]](%[[VAL_18]], %[[VAL_16]]) : (!fir.ref<!fir.char<1,?>>, index) -> !fir.boxchar<1>
+   print *, char_func_dummy()
+  end subroutine
+end subroutine
+
+! CHECK-LABEL: func @_QPcapture_char_func_assumed_dummy(
+! CHECK-SAME:  %[[VAL_0:.*]]: tuple<!fir.boxproc<() -> ()>, i64> {fir.char_proc}) {
+subroutine capture_char_func_assumed_dummy(char_func_dummy)
+  character(*),external :: char_func_dummy
+! CHECK:  %[[VAL_1:.*]] = fir.alloca tuple<tuple<!fir.boxproc<() -> ()>, i64>>
+! CHECK:  %[[VAL_2:.*]] = arith.constant 0 : i32
+! CHECK:  %[[VAL_3:.*]] = fir.coordinate_of %[[VAL_1]], %[[VAL_2]] : (!fir.ref<tuple<tuple<!fir.boxproc<() -> ()>, i64>>>, i32) -> !fir.ref<tuple<!fir.boxproc<() -> ()>, i64>>
+! CHECK:  fir.store %[[VAL_0]] to %[[VAL_3]] : !fir.ref<tuple<!fir.boxproc<() -> ()>, i64>>
+! CHECK:  fir.call @_QFcapture_char_func_assumed_dummyPinternal(%[[VAL_1]]) : (!fir.ref<tuple<tuple<!fir.boxproc<() -> ()>, i64>>>) -> ()
+  call internal()
+contains
+! CHECK-LABEL: func @_QFcapture_char_func_assumed_dummyPinternal(
+! CHECK-SAME:  %[[VAL_0:.*]]: !fir.ref<tuple<tuple<!fir.boxproc<() -> ()>, i64>>> {fir.host_assoc}) {
+  subroutine internal()
+! CHECK:  %[[VAL_1:.*]] = arith.constant 0 : i32
+! CHECK:  %[[VAL_2:.*]] = fir.coordinate_of %[[VAL_0]], %[[VAL_1]] : (!fir.ref<tuple<tuple<!fir.boxproc<() -> ()>, i64>>>, i32) -> !fir.ref<tuple<!fir.boxproc<() -> ()>, i64>>
+! CHECK:  %[[VAL_3:.*]] = fir.load %[[VAL_2]] : !fir.ref<tuple<!fir.boxproc<() -> ()>, i64>>
+! CHECK:  %[[VAL_9:.*]] = fir.extract_value %[[VAL_3]], [0 : index] : (tuple<!fir.boxproc<() -> ()>, i64>) -> !fir.boxproc<() -> ()>
+! CHECK:  %[[VAL_10:.*]] = fir.box_addr %[[VAL_9]] : (!fir.boxproc<() -> ()>) -> (() -> ())
+! CHECK:  %[[VAL_11:.*]] = fir.extract_value %[[VAL_3]], [1 : index] : (tuple<!fir.boxproc<() -> ()>, i64>) -> i64
+! CHECK:  %[[VAL_12:.*]] = fir.call @llvm.stacksave() : () -> !fir.ref<i8>
+! CHECK:  %[[VAL_13:.*]] = fir.alloca !fir.char<1,?>(%[[VAL_11]] : i64) {bindc_name = ".result"}
+! CHECK:  %[[VAL_14:.*]] = fir.convert %[[VAL_10]] : (() -> ()) -> ((!fir.ref<!fir.char<1,?>>, index) -> !fir.boxchar<1>)
+! CHECK:  %[[VAL_15:.*]] = fir.convert %[[VAL_11]] : (i64) -> index
+! CHECK:  %[[VAL_16:.*]] = fir.call %[[VAL_14]](%[[VAL_13]], %[[VAL_15]]) : (!fir.ref<!fir.char<1,?>>, index) -> !fir.boxchar<1>
+   print *, char_func_dummy()
+  end subroutine
+end subroutine
+
+! CHECK-LABEL: func @_QPcapture_char_func(
+! CHECK-SAME:  %[[VAL_0:.*]]: !fir.ref<i32> {fir.bindc_name = "n"}) {
+subroutine capture_char_func(n)
+  character(n), external :: char_func
+! CHECK:  %[[VAL_1:.*]] = fir.alloca tuple<!fir.ref<i32>>
+! CHECK:  %[[VAL_2:.*]] = arith.constant 0 : i32
+! CHECK:  %[[VAL_3:.*]] = fir.coordinate_of %[[VAL_1]], %[[VAL_2]] : (!fir.ref<tuple<!fir.ref<i32>>>, i32) -> !fir.llvm_ptr<!fir.ref<i32>>
+! CHECK:  fir.store %[[VAL_0]] to %[[VAL_3]] : !fir.llvm_ptr<!fir.ref<i32>>
+! CHECK:  fir.call @_QFcapture_char_funcPinternal(%[[VAL_1]]) : (!fir.ref<tuple<!fir.ref<i32>>>) -> ()
+  call internal()
+contains
+! CHECK-LABEL: func @_QFcapture_char_funcPinternal(
+! CHECK-SAME:  %[[VAL_0:.*]]: !fir.ref<tuple<!fir.ref<i32>>> {fir.host_assoc})
+  subroutine internal()
+   print *, char_func()
+  end subroutine
+end subroutine
+
+! CHECK-LABEL: func @_QPcapture_array_func(
+! CHECK-SAME:  %[[VAL_0:.*]]: !fir.ref<i32> {fir.bindc_name = "n"}) {
+subroutine capture_array_func(n)
+  integer :: n
+  interface
+  function array_func()
+    import :: n
+    integer :: array_func(n)
+  end function
+  end interface
+! CHECK:  %[[VAL_1:.*]] = fir.alloca tuple<!fir.ref<i32>>
+! CHECK:  %[[VAL_2:.*]] = arith.constant 0 : i32
+! CHECK:  %[[VAL_3:.*]] = fir.coordinate_of %[[VAL_1]], %[[VAL_2]] : (!fir.ref<tuple<!fir.ref<i32>>>, i32) -> !fir.llvm_ptr<!fir.ref<i32>>
+! CHECK:  fir.store %[[VAL_0]] to %[[VAL_3]] : !fir.llvm_ptr<!fir.ref<i32>>
+! CHECK:  fir.call @_QFcapture_array_funcPinternal(%[[VAL_1]]) : (!fir.ref<tuple<!fir.ref<i32>>>) -> ()
+  call internal()
+contains
+  subroutine internal()
+! CHECK-LABEL: func @_QFcapture_array_funcPinternal(
+! CHECK-SAME:  %[[VAL_0:.*]]: !fir.ref<tuple<!fir.ref<i32>>> {fir.host_assoc}) {
+! CHECK:  %[[VAL_1:.*]] = arith.constant 0 : i32
+! CHECK:  %[[VAL_2:.*]] = fir.coordinate_of %[[VAL_0]], %[[VAL_1]] : (!fir.ref<tuple<!fir.ref<i32>>>, i32) -> !fir.llvm_ptr<!fir.ref<i32>>
+! CHECK:  %[[VAL_3:.*]] = fir.load %[[VAL_2]] : !fir.llvm_ptr<!fir.ref<i32>>
+! CHECK:  %[[VAL_9:.*]] = fir.load %[[VAL_3]] : !fir.ref<i32>
+! CHECK:  %[[VAL_10:.*]] = fir.convert %[[VAL_9]] : (i32) -> i64
+! CHECK:  %[[VAL_11:.*]] = arith.constant 1 : i64
+! CHECK:  %[[VAL_12:.*]] = arith.subi %[[VAL_10]], %[[VAL_11]] : i64
+! CHECK:  %[[VAL_13:.*]] = arith.constant 1 : i64
+! CHECK:  %[[VAL_14:.*]] = arith.addi %[[VAL_12]], %[[VAL_13]] : i64
+! CHECK:  %[[VAL_15:.*]] = fir.convert %[[VAL_14]] : (i64) -> index
+! CHECK:  %[[VAL_16:.*]] = fir.call @llvm.stacksave() : () -> !fir.ref<i8>
+! CHECK:  %[[VAL_17:.*]] = fir.alloca !fir.array<?xi32>, %[[VAL_15]] {bindc_name = ".result"}
+   print *, array_func()
+  end subroutine
+end subroutine
+
+module define_char_func
+  contains
+  function return_char(n)
+    integer :: n
+    character(n) :: return_char
+    return_char = "a"
+  end function
+end module
+
+! CHECK-LABEL: func @_QPuse_module() {
+subroutine use_module()
+  ! verify there is no capture triggers by the interface.
+  use define_char_func
+! CHECK:  fir.call @_QFuse_modulePinternal() : () -> ()
+  call internal()
+  contains
+! CHECK-LABEL: func @_QFuse_modulePinternal() {
+  subroutine internal()
+    print *, return_char(42)
+  end subroutine
+end subroutine