[flang-commits] [flang] [Flang]: Lowering reference to functions that return a procedure pointer (PR #78194)

Daniel Chen via flang-commits flang-commits at lists.llvm.org
Mon Jan 29 10:18:06 PST 2024


https://github.com/DanielCChen updated https://github.com/llvm/llvm-project/pull/78194

>From c1a4c17af57392d8debffa02976fabe16960e11b Mon Sep 17 00:00:00 2001
From: cdchen-ca <cdchen at ca.ibm.com>
Date: Mon, 15 Jan 2024 12:17:34 -0500
Subject: [PATCH 01/15] [Flang]: Lowering reference to functions that return a
 procedure pointer.

---
 flang/lib/Lower/CallInterface.cpp      | 64 +++++++++++++-------------
 flang/lib/Lower/ConvertCall.cpp        | 11 ++++-
 flang/lib/Lower/ConvertExprToHLFIR.cpp | 11 +++--
 3 files changed, 51 insertions(+), 35 deletions(-)

diff --git a/flang/lib/Lower/CallInterface.cpp b/flang/lib/Lower/CallInterface.cpp
index 06150da6f23999..4333c652b09b09 100644
--- a/flang/lib/Lower/CallInterface.cpp
+++ b/flang/lib/Lower/CallInterface.cpp
@@ -1111,39 +1111,41 @@ class Fortran::lower::CallInterfaceImpl {
       const Fortran::evaluate::characteristics::FunctionResult &result) {
     using Attr = Fortran::evaluate::characteristics::FunctionResult::Attr;
     mlir::Type mlirType;
-    if (auto proc{result.IsProcedurePointer()})
+    if (auto proc{result.IsProcedurePointer()}) {
       mlirType = fir::BoxProcType::get(
           &mlirContext, getProcedureType(*proc, interface.converter));
-    else {
-      const Fortran::evaluate::characteristics::TypeAndShape *typeAndShape =
-          result.GetTypeAndShape();
-      assert(typeAndShape && "expect type for non proc pointer result");
-      mlirType = translateDynamicType(typeAndShape->type());
-      const auto *resTypeAndShape{result.GetTypeAndShape()};
-      bool resIsPolymorphic =
-          resTypeAndShape && resTypeAndShape->type().IsPolymorphic();
-      bool resIsAssumedType =
-          resTypeAndShape && resTypeAndShape->type().IsAssumedType();
-      if (std::optional<fir::SequenceType::Shape> bounds =
-              getBounds(*typeAndShape))
-        mlirType = fir::SequenceType::get(*bounds, mlirType);
-      if (result.attrs.test(Attr::Allocatable))
-        mlirType = fir::wrapInClassOrBoxType(
-            fir::HeapType::get(mlirType), resIsPolymorphic, resIsAssumedType);
-      if (result.attrs.test(Attr::Pointer))
-        mlirType =
-            fir::wrapInClassOrBoxType(fir::PointerType::get(mlirType),
-                                      resIsPolymorphic, resIsAssumedType);
-
-      if (fir::isa_char(mlirType)) {
-        // Character scalar results must be passed as arguments in lowering so
-        // that an assumed length character function callee can access the
-        // result length. A function with a result requiring an explicit
-        // interface does not have to be compatible with assumed length
-        // function, but most compilers supports it.
-        handleImplicitCharacterResult(typeAndShape->type());
-        return;
-      }
+      addFirResult(mlirType, FirPlaceHolder::resultEntityPosition,
+                   Property::Value);
+      return;
+    }
+
+    const Fortran::evaluate::characteristics::TypeAndShape *typeAndShape =
+        result.GetTypeAndShape();
+    assert(typeAndShape && "expect type for non proc pointer result");
+    mlirType = translateDynamicType(typeAndShape->type());
+    fir::SequenceType::Shape bounds = getBounds(typeAndShape->shape());
+    const auto *resTypeAndShape{result.GetTypeAndShape()};
+    bool resIsPolymorphic =
+        resTypeAndShape && resTypeAndShape->type().IsPolymorphic();
+    bool resIsAssumedType =
+        resTypeAndShape && resTypeAndShape->type().IsAssumedType();
+    if (!bounds.empty())
+      mlirType = fir::SequenceType::get(bounds, mlirType);
+    if (result.attrs.test(Attr::Allocatable))
+      mlirType = fir::wrapInClassOrBoxType(fir::HeapType::get(mlirType),
+                                           resIsPolymorphic, resIsAssumedType);
+    if (result.attrs.test(Attr::Pointer))
+      mlirType = fir::wrapInClassOrBoxType(fir::PointerType::get(mlirType),
+                                           resIsPolymorphic, resIsAssumedType);
+
+    if (fir::isa_char(mlirType)) {
+      // Character scalar results must be passed as arguments in lowering so
+      // that an assumed length character function callee can access the
+      // result length. A function with a result requiring an explicit
+      // interface does not have to be compatible with assumed length
+      // function, but most compilers supports it.
+      handleImplicitCharacterResult(typeAndShape->type());
+      return;
     }
 
     addFirResult(mlirType, FirPlaceHolder::resultEntityPosition,
diff --git a/flang/lib/Lower/ConvertCall.cpp b/flang/lib/Lower/ConvertCall.cpp
index 01e08402c0539c..3ab76d19d3b6e3 100644
--- a/flang/lib/Lower/ConvertCall.cpp
+++ b/flang/lib/Lower/ConvertCall.cpp
@@ -156,7 +156,10 @@ fir::ExtendedValue Fortran::lower::genCallOpAndResult(
   using PassBy = Fortran::lower::CallerInterface::PassEntityBy;
   // Handle cases where caller must allocate the result or a fir.box for it.
   bool mustPopSymMap = false;
-  if (caller.mustMapInterfaceSymbols()) {
+
+  // Is procedure pointer functin result.
+  bool isProcedurePointer = resultType->isa<fir::BoxProcType>();
+  if (!isProcedurePointer && caller.mustMapInterfaceSymbols()) {
     symMap.pushScope();
     mustPopSymMap = true;
     Fortran::lower::mapCallInterfaceSymbols(converter, caller, symMap);
@@ -202,6 +205,8 @@ fir::ExtendedValue Fortran::lower::genCallOpAndResult(
     llvm::SmallVector<mlir::Value> lengths;
     if (!caller.callerAllocateResult())
       return {};
+    if (isProcedurePointer)
+      return {};
     mlir::Type type = caller.getResultStorageType();
     if (type.isa<fir::SequenceType>())
       caller.walkResultExtents([&](const Fortran::lower::SomeExpr &e) {
@@ -446,6 +451,7 @@ fir::ExtendedValue Fortran::lower::genCallOpAndResult(
       callResult = call.getResult(0);
   }
 
+  // if (!isProcedurePointer && caller.mustSaveResult()) {
   if (caller.mustSaveResult()) {
     assert(allocatedResult.has_value());
     builder.create<fir::SaveResultOp>(loc, callResult,
@@ -1379,6 +1385,9 @@ genUserCall(Fortran::lower::PreparedActualArguments &loweredActuals,
       loc, callContext.converter, callContext.symMap, callContext.stmtCtx,
       caller, callSiteType, callContext.resultType,
       callContext.isElementalProcWithArrayArgs());
+  // For procedure pointer function result, just return the call.
+  if (callContext.resultType->isa<fir::BoxProcType>())
+    return hlfir::EntityWithAttributes(fir::getBase(result));
 
   /// Clean-up associations and copy-in.
   for (auto cleanUp : callCleanUps)
diff --git a/flang/lib/Lower/ConvertExprToHLFIR.cpp b/flang/lib/Lower/ConvertExprToHLFIR.cpp
index 01e58144fa4b58..76b8e16e7767c2 100644
--- a/flang/lib/Lower/ConvertExprToHLFIR.cpp
+++ b/flang/lib/Lower/ConvertExprToHLFIR.cpp
@@ -1433,9 +1433,14 @@ class HlfirBuilder {
   }
 
   hlfir::EntityWithAttributes gen(const Fortran::evaluate::ProcedureRef &expr) {
-    TODO(
-        getLoc(),
-        "lowering function references that return procedure pointers to HLFIR");
+    fir::FirOpBuilder &builder = getBuilder();
+    Fortran::evaluate::ProcedureDesignator proc{expr.proc()};
+    auto procTy{Fortran::lower::translateSignature(proc, getConverter())};
+    mlir::Type resType = fir::BoxProcType::get(builder.getContext(), procTy);
+    auto result = Fortran::lower::convertCallToHLFIR(
+        getLoc(), getConverter(), expr, resType, getSymMap(), getStmtCtx());
+    assert(result.has_value());
+    return *result;
   }
 
   template <typename T>

>From d2b984a7fd2881893c60e5ec5a536ee1256dae4d Mon Sep 17 00:00:00 2001
From: cdchen-ca <cdchen at ca.ibm.com>
Date: Mon, 15 Jan 2024 12:24:01 -0500
Subject: [PATCH 02/15] [Flang]: Lowering reference to functions that return a
 procedure pointer.

---
 flang/lib/Lower/ConvertCall.cpp | 1 -
 1 file changed, 1 deletion(-)

diff --git a/flang/lib/Lower/ConvertCall.cpp b/flang/lib/Lower/ConvertCall.cpp
index 3ab76d19d3b6e3..e221800ac9dfb7 100644
--- a/flang/lib/Lower/ConvertCall.cpp
+++ b/flang/lib/Lower/ConvertCall.cpp
@@ -451,7 +451,6 @@ fir::ExtendedValue Fortran::lower::genCallOpAndResult(
       callResult = call.getResult(0);
   }
 
-  // if (!isProcedurePointer && caller.mustSaveResult()) {
   if (caller.mustSaveResult()) {
     assert(allocatedResult.has_value());
     builder.create<fir::SaveResultOp>(loc, callResult,

>From cb32f38e503006758faf59f8588567db64215b98 Mon Sep 17 00:00:00 2001
From: cdchen-ca <cdchen at ca.ibm.com>
Date: Mon, 15 Jan 2024 15:31:08 -0500
Subject: [PATCH 03/15] [Flang]: Fix LIT test failures that resultType could be
 null.

---
 flang/lib/Lower/ConvertCall.cpp | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/flang/lib/Lower/ConvertCall.cpp b/flang/lib/Lower/ConvertCall.cpp
index e221800ac9dfb7..e80b53a96ac865 100644
--- a/flang/lib/Lower/ConvertCall.cpp
+++ b/flang/lib/Lower/ConvertCall.cpp
@@ -158,7 +158,7 @@ fir::ExtendedValue Fortran::lower::genCallOpAndResult(
   bool mustPopSymMap = false;
 
   // Is procedure pointer functin result.
-  bool isProcedurePointer = resultType->isa<fir::BoxProcType>();
+  bool isProcedurePointer = resultType && resultType->isa<fir::BoxProcType>();
   if (!isProcedurePointer && caller.mustMapInterfaceSymbols()) {
     symMap.pushScope();
     mustPopSymMap = true;
@@ -1385,7 +1385,7 @@ genUserCall(Fortran::lower::PreparedActualArguments &loweredActuals,
       caller, callSiteType, callContext.resultType,
       callContext.isElementalProcWithArrayArgs());
   // For procedure pointer function result, just return the call.
-  if (callContext.resultType->isa<fir::BoxProcType>())
+  if (callContext.resultType && callContext.resultType->isa<fir::BoxProcType>())
     return hlfir::EntityWithAttributes(fir::getBase(result));
 
   /// Clean-up associations and copy-in.

>From 79671505d4eb1a6f8ae65010514024cc905b7431 Mon Sep 17 00:00:00 2001
From: cdchen-ca <cdchen at ca.ibm.com>
Date: Wed, 17 Jan 2024 14:05:26 -0500
Subject: [PATCH 04/15] [Flang] Add LIT test.

---
 flang/test/Lower/HLFIR/procedure-pointer.f90 | 62 ++++++++++++++++++++
 1 file changed, 62 insertions(+)

diff --git a/flang/test/Lower/HLFIR/procedure-pointer.f90 b/flang/test/Lower/HLFIR/procedure-pointer.f90
index 4ea71eef912a30..013c87a975a244 100644
--- a/flang/test/Lower/HLFIR/procedure-pointer.f90
+++ b/flang/test/Lower/HLFIR/procedure-pointer.f90
@@ -2,6 +2,7 @@
 ! 1. declaration and initialization
 ! 2. pointer assignment and invocation
 ! 3. procedure pointer argument passing.
+! 3. procedure pointer function result.
 ! RUN: bbc -emit-hlfir -o - %s | FileCheck %s
 
 module m
@@ -244,6 +245,67 @@ subroutine sub9()
 ! CHECK: fir.call @_QPfoo2(%[[VAL_10]]) fastmath<contract> : (!fir.ref<!fir.boxproc<() -> ()>>) -> ()
 end
 
+subroutine sub10()
+use m
+
+  procedure(real_func), pointer :: p1
+! CHECK: %[[VAL_0:.*]] = fir.alloca !fir.boxproc<(!fir.ref<f32>) -> f32> {bindc_name = "p1", uniq_name = "_QFsub10Ep1"}
+! CHECK: %[[VAL_1:.*]] = fir.zero_bits (!fir.ref<f32>) -> f32
+! CHECK: %[[VAL_2:.*]] = fir.emboxproc %[[VAL_1]] : ((!fir.ref<f32>) -> f32) -> !fir.boxproc<(!fir.ref<f32>) -> f32>
+! CHECK: fir.store %[[VAL_2]] to %[[VAL_0]] : !fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>
+! CHECK: %[[VAL_3:.*]]:2 = hlfir.declare %[[VAL_0]] {fortran_attrs = #fir.var_attrs<pointer>, uniq_name = "_QFsub10Ep1"} : (!fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>) -> (!fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>, !fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>)
+
+  p1 => reffunc(5)
+! CHECK: %c5_i32 = arith.constant 5 : i32
+! CHECK: %[[VAL_4:.*]]:3 = hlfir.associate %c5_i32 {adapt.valuebyref} : (i32) -> (!fir.ref<i32>, !fir.ref<i32>, i1)
+! CHECK: %[[VAL_5:.*]] = fir.call @_QFsub10Preffunc(%[[VAL_4]]#1) fastmath<contract> : (!fir.ref<i32>) -> !fir.boxproc<(!fir.ref<f32>) -> f32>
+! CHECK: fir.store %[[VAL_5]] to %[[VAL_3]]#0 : !fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>
+
+contains
+  function reffunc(arg) result(pp)
+    integer :: arg
+    procedure(real_func), pointer :: pp
+! CHECK: %[[VAL_0:.*]]:2 = hlfir.declare %arg0 {uniq_name = "_QFsub10FreffuncEarg"} : (!fir.ref<i32>) -> (!fir.ref<i32>, !fir.ref<i32>)
+! CHECK: %[[VAL_1:.*]] = fir.alloca !fir.boxproc<(!fir.ref<f32>) -> f32> {bindc_name = "pp", uniq_name = "_QFsub10FreffuncEpp"}
+! CHECK: %[[VAL_2:.*]] = fir.zero_bits (!fir.ref<f32>) -> f32
+! CHECK: %[[VAL_3:.*]] = fir.emboxproc %[[VAL_2]] : ((!fir.ref<f32>) -> f32) -> !fir.boxproc<(!fir.ref<f32>) -> f32>
+! CHECK: fir.store %[[VAL_3]] to %[[VAL_1]] : !fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>
+! CHECK: %[[VAL_4:.*]]:2 = hlfir.declare %[[VAL_1]] {fortran_attrs = #fir.var_attrs<pointer>, uniq_name = "_QFsub10FreffuncEpp"} : (!fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>) -> (!fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>, !fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>)
+
+    pp => real_func
+! CHECK: %[[VAL_5:.*]] = fir.address_of(@_QPreal_func) : (!fir.ref<f32>) -> f32
+! CHECK: %[[VAL_6:.*]] = fir.emboxproc %[[VAL_5]] : ((!fir.ref<f32>) -> f32) -> !fir.boxproc<() -> ()>
+! CHECK: %[[VAL_7:.*]] = fir.convert %[[VAL_6]] : (!fir.boxproc<() -> ()>) -> !fir.boxproc<(!fir.ref<f32>) -> f32>
+! CHECK: fir.store %[[VAL_7]] to %[[VAL_4]]#0 : !fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>
+! CHECK: %[[VAL_8:.*]] = fir.load %[[VAL_4]]#1 : !fir.ref<!fir.boxproc<(!fir.ref<f32>) -> f32>>
+! CHECK: return %[[VAL_8]] : !fir.boxproc<(!fir.ref<f32>) -> f32>
+  end
+end
+
+subroutine sub11()
+use m
+  interface
+    function reffunc(arg) result(pp)
+      import
+      integer :: arg
+      procedure(char_func), pointer :: pp
+    end
+  end interface
+
+  procedure(char_func), pointer :: p1
+! CHECK: %[[VAL_0:.*]] = fir.alloca !fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>> {bindc_name = "p1", uniq_name = "_QFsub11Ep1"}
+! CHECK: %[[VAL_1:.*]] = fir.zero_bits (!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>
+! CHECK: %[[VAL_2:.*]] = fir.emboxproc %[[VAL_1]] : ((!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>) -> !fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>
+! CHECK: fir.store %[[VAL_2]] to %[[VAL_0]] : !fir.ref<!fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>>
+! CHECK: %[[VAL_3:.*]]:2 = hlfir.declare %[[VAL_0]] {fortran_attrs = #fir.var_attrs<pointer>, uniq_name = "_QFsub11Ep1"} : (!fir.ref<!fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>>) -> (!fir.ref<!fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>>, !fir.ref<!fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>>)
+
+  p1 => reffunc(5)
+! CHECK: %c5_i32 = arith.constant 5 : i32
+! CHECK: %[[VAL_4:.*]]:3 = hlfir.associate %c5_i32 {adapt.valuebyref} : (i32) -> (!fir.ref<i32>, !fir.ref<i32>, i1)
+! CHECK: %[[VAL_5:.*]] = fir.call @_QPreffunc(%4#1) fastmath<contract> : (!fir.ref<i32>) -> !fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>
+! CHECK: fir.store %[[VAL_5]] to %[[VAL_3]]#0 : !fir.ref<!fir.boxproc<(!fir.ref<i32>) -> !fir.box<!fir.ptr<!fir.char<1,?>>>>>
+! CHECK: return
+end
 
 ! CHECK-LABEL: fir.global internal @_QFsub1Ep2 : !fir.boxproc<(!fir.ref<f32>) -> f32> {
 ! CHECK: %[[VAL_0:.*]] = fir.zero_bits (!fir.ref<f32>) -> f32

>From bcdf3d2bd145b2a056cc74f4115b80496fdbb6f8 Mon Sep 17 00:00:00 2001
From: cdchen-ca <cdchen at ca.ibm.com>
Date: Wed, 24 Jan 2024 14:25:03 -0500
Subject: [PATCH 05/15] [Flang] Support ASSOCIATED to have the first argument
 as a function that returns a procedure pointer.

---
 flang/lib/Optimizer/Builder/IntrinsicCall.cpp | 7 +++++--
 1 file changed, 5 insertions(+), 2 deletions(-)

diff --git a/flang/lib/Optimizer/Builder/IntrinsicCall.cpp b/flang/lib/Optimizer/Builder/IntrinsicCall.cpp
index a9edabf014fafc..045e54deebaab3 100644
--- a/flang/lib/Optimizer/Builder/IntrinsicCall.cpp
+++ b/flang/lib/Optimizer/Builder/IntrinsicCall.cpp
@@ -2158,9 +2158,12 @@ fir::ExtendedValue
 IntrinsicLibrary::genAssociated(mlir::Type resultType,
                                 llvm::ArrayRef<fir::ExtendedValue> args) {
   assert(args.size() == 2);
-  if (fir::isBoxProcAddressType(fir::getBase(args[0]).getType())) {
+  mlir::Type ptrTy = fir::getBase(args[0]).getType();
+  if (fir::isBoxProcAddressType(ptrTy) || ptrTy.isa<fir::BoxProcType>()) {
     mlir::Value pointerBoxProc =
-        builder.create<fir::LoadOp>(loc, fir::getBase(args[0]));
+        fir::isBoxProcAddressType(ptrTy)
+            ? builder.create<fir::LoadOp>(loc, fir::getBase(args[0]))
+            : fir::getBase(args[0]);
     mlir::Value pointerTarget =
         builder.create<fir::BoxAddrOp>(loc, pointerBoxProc);
     if (isStaticallyAbsent(args[1]))

>From b31de75ff6ef1e3c99fa1bffbc74c8c94e4c0d9e Mon Sep 17 00:00:00 2001
From: cdchen-ca <cdchen at ca.ibm.com>
Date: Wed, 24 Jan 2024 14:58:38 -0500
Subject: [PATCH 06/15] [Flang] Add LIT test for ASSOCIATED with procedure
 pointer function result.

---
 .../Intrinsics/associated-proc-pointers.f90   | 28 +++++++++++++++++++
 1 file changed, 28 insertions(+)

diff --git a/flang/test/Lower/Intrinsics/associated-proc-pointers.f90 b/flang/test/Lower/Intrinsics/associated-proc-pointers.f90
index 248b0aff8d286e..1772b9afdfc0b0 100644
--- a/flang/test/Lower/Intrinsics/associated-proc-pointers.f90
+++ b/flang/test/Lower/Intrinsics/associated-proc-pointers.f90
@@ -114,3 +114,31 @@ character(10) function char_func()
 ! CHECK:           %[[VAL_18:.*]] = arith.cmpi ne, %[[VAL_17]], %[[VAL_14]] : i64
 ! CHECK:           %[[VAL_19:.*]] = arith.andi %[[VAL_16]], %[[VAL_18]] : i1
 ! CHECK:           %[[VAL_20:.*]] = fir.convert %[[VAL_19]] : (i1) -> !fir.logical<4>
+
+subroutine test_proc_pointer_6()
+  interface
+    real function func()
+    end
+  end interface
+  logical :: ll
+  ll = associated(reffunc(), func)
+contains
+  function reffunc() result(pp)
+    procedure(func), pointer :: pp
+  end
+end
+! CHECK: %[[VAL_0:.*]] = fir.alloca !fir.logical<4> {bindc_name = "ll", uniq_name = "_QFtest_proc_pointer_6Ell"}
+! CHECK: %[[VAL_1:.*]]:2 = hlfir.declare %[[VAL_0]] {uniq_name = "_QFtest_proc_pointer_6Ell"} : (!fir.ref<!fir.logical<4>>) -> (!fir.ref<!fir.logical<4>>, !fir.ref<!fir.logical<4>>)
+! CHECK: %[[VAL_2:.*]] = fir.call @_QFtest_proc_pointer_6Preffunc() fastmath<contract> : () -> !fir.boxproc<() -> f32>
+! CHECK: %[[VAL_3:.*]] = fir.address_of(@_QPfunc) : () -> f32
+! CHECK: %[[VAL_4:.*]] = fir.emboxproc %[[VAL_3]] : (() -> f32) -> !fir.boxproc<() -> ()>
+! CHECK: %[[VAL_5:.*]] = fir.box_addr %[[VAL_2]] : (!fir.boxproc<() -> f32>) -> (() -> f32)
+! CHECK: %[[VAL_6:.*]] = fir.box_addr %[[VAL_4]] : (!fir.boxproc<() -> ()>) -> (() -> ())
+! CHECK: %[[VAL_7:.*]] = fir.convert %[[VAL_5]] : (() -> f32) -> i64
+! CHECK: %[[VAL_8:.*]] = fir.convert %[[VAL_6]] : (() -> ()) -> i64
+! CHECK: %[[VAL_9:.*]] = arith.cmpi eq, %[[VAL_7]], %[[VAL_8]] : i64
+! CHECK: %c0_i64 = arith.constant 0 : i64
+! CHECK: %[[VAL_10:.*]] = arith.cmpi ne, %c0_i64, %[[VAL_7]] : i64
+! CHECK: %[[VAL_11:.*]] = arith.andi %[[VAL_9]], %[[VAL_10]] : i1
+! CHECK: %[[VAL_12:.*]] = fir.convert %[[VAL_11]] : (i1) -> !fir.logical<4>
+! CHECK: hlfir.assign %[[VAL_12]] to %[[VAL_1]]#0 : !fir.logical<4>, !fir.ref<!fir.logical<4>>

>From 488ddf47d14a2f0115cd7096e513de809ff74892 Mon Sep 17 00:00:00 2001
From: cdchen-ca <cdchen at ca.ibm.com>
Date: Mon, 15 Jan 2024 12:17:34 -0500
Subject: [PATCH 07/15] [Flang]: Lowering reference to functions that return a
 procedure pointer.

---
 flang/lib/Lower/ConvertCall.cpp | 1 +
 1 file changed, 1 insertion(+)

diff --git a/flang/lib/Lower/ConvertCall.cpp b/flang/lib/Lower/ConvertCall.cpp
index e80b53a96ac865..ba0b4d4413e755 100644
--- a/flang/lib/Lower/ConvertCall.cpp
+++ b/flang/lib/Lower/ConvertCall.cpp
@@ -451,6 +451,7 @@ fir::ExtendedValue Fortran::lower::genCallOpAndResult(
       callResult = call.getResult(0);
   }
 
+  // if (!isProcedurePointer && caller.mustSaveResult()) {
   if (caller.mustSaveResult()) {
     assert(allocatedResult.has_value());
     builder.create<fir::SaveResultOp>(loc, callResult,

>From a5391bb39b72b32785318768f64db93d58d3b7c8 Mon Sep 17 00:00:00 2001
From: jeanPerier <jperier at nvidia.com>
Date: Fri, 26 Jan 2024 16:01:51 +0100
Subject: [PATCH 08/15] [flang] Lower passing non assumed-rank/size to
 assumed-ranks (#79145)

Start implementing assumed-rank support as described in
https://github.com/llvm/llvm-project/blob/main/flang/docs/AssumedRank.md

This commit holds the minimal support for lowering calls to procedure
with assumed-rank arguments where the procedure implementation is done
in C.

The case for passing assumed-size to assumed-rank is left TODO since it
will be done a change in assumed-size lowering that is better done in
another patch.

Care is taken to set the lower bounds to zero when passing non allocatable no pointer as descriptor
to a BIND(C) procedure as required per 18.5.3 point 3. This was not done before while the requirements also applies to non assumed-rank descriptors. This change  required special attention with IGNORE_TKR(t) to avoid emitting invalid fir.rebox operations (the actual argument type must be used in this case as the output type).

Implementation of Fortran procedure with assumed-rank arguments is still
TODO.
---
 flang/lib/Lower/CallInterface.cpp | 16 ++++++++--------
 1 file changed, 8 insertions(+), 8 deletions(-)

diff --git a/flang/lib/Lower/CallInterface.cpp b/flang/lib/Lower/CallInterface.cpp
index 4333c652b09b09..bc81b40a53885a 100644
--- a/flang/lib/Lower/CallInterface.cpp
+++ b/flang/lib/Lower/CallInterface.cpp
@@ -1118,25 +1118,25 @@ class Fortran::lower::CallInterfaceImpl {
                    Property::Value);
       return;
     }
-
     const Fortran::evaluate::characteristics::TypeAndShape *typeAndShape =
         result.GetTypeAndShape();
     assert(typeAndShape && "expect type for non proc pointer result");
     mlirType = translateDynamicType(typeAndShape->type());
-    fir::SequenceType::Shape bounds = getBounds(typeAndShape->shape());
     const auto *resTypeAndShape{result.GetTypeAndShape()};
     bool resIsPolymorphic =
         resTypeAndShape && resTypeAndShape->type().IsPolymorphic();
     bool resIsAssumedType =
         resTypeAndShape && resTypeAndShape->type().IsAssumedType();
-    if (!bounds.empty())
-      mlirType = fir::SequenceType::get(bounds, mlirType);
+    if (std::optional<fir::SequenceType::Shape> bounds =
+            getBounds(*typeAndShape))
+      mlirType = fir::SequenceType::get(*bounds, mlirType);
     if (result.attrs.test(Attr::Allocatable))
-      mlirType = fir::wrapInClassOrBoxType(fir::HeapType::get(mlirType),
-                                           resIsPolymorphic, resIsAssumedType);
+      mlirType = fir::wrapInClassOrBoxType(
+          fir::HeapType::get(mlirType), resIsPolymorphic, resIsAssumedType);
     if (result.attrs.test(Attr::Pointer))
-      mlirType = fir::wrapInClassOrBoxType(fir::PointerType::get(mlirType),
-                                           resIsPolymorphic, resIsAssumedType);
+      mlirType =
+          fir::wrapInClassOrBoxType(fir::PointerType::get(mlirType),
+                                    resIsPolymorphic, resIsAssumedType);
 
     if (fir::isa_char(mlirType)) {
       // Character scalar results must be passed as arguments in lowering so

>From 9c16f509a683458be1f908a2d42c84ad7c907375 Mon Sep 17 00:00:00 2001
From: cdchen-ca <cdchen at ca.ibm.com>
Date: Mon, 15 Jan 2024 12:24:01 -0500
Subject: [PATCH 09/15] [Flang]: Lowering reference to functions that return a
 procedure pointer.

---
 flang/lib/Lower/ConvertCall.cpp | 1 -
 1 file changed, 1 deletion(-)

diff --git a/flang/lib/Lower/ConvertCall.cpp b/flang/lib/Lower/ConvertCall.cpp
index ba0b4d4413e755..e80b53a96ac865 100644
--- a/flang/lib/Lower/ConvertCall.cpp
+++ b/flang/lib/Lower/ConvertCall.cpp
@@ -451,7 +451,6 @@ fir::ExtendedValue Fortran::lower::genCallOpAndResult(
       callResult = call.getResult(0);
   }
 
-  // if (!isProcedurePointer && caller.mustSaveResult()) {
   if (caller.mustSaveResult()) {
     assert(allocatedResult.has_value());
     builder.create<fir::SaveResultOp>(loc, callResult,

>From 7e4316a6fe2347719859e04d8a1ee60dba89143d Mon Sep 17 00:00:00 2001
From: cdchen-ca <cdchen at ca.ibm.com>
Date: Mon, 15 Jan 2024 12:17:34 -0500
Subject: [PATCH 10/15] [Flang]: Lowering reference to functions that return a
 procedure pointer.

---
 flang/lib/Lower/ConvertCall.cpp | 1 +
 1 file changed, 1 insertion(+)

diff --git a/flang/lib/Lower/ConvertCall.cpp b/flang/lib/Lower/ConvertCall.cpp
index e80b53a96ac865..ba0b4d4413e755 100644
--- a/flang/lib/Lower/ConvertCall.cpp
+++ b/flang/lib/Lower/ConvertCall.cpp
@@ -451,6 +451,7 @@ fir::ExtendedValue Fortran::lower::genCallOpAndResult(
       callResult = call.getResult(0);
   }
 
+  // if (!isProcedurePointer && caller.mustSaveResult()) {
   if (caller.mustSaveResult()) {
     assert(allocatedResult.has_value());
     builder.create<fir::SaveResultOp>(loc, callResult,

>From 8960280acfcd2c445941c2460ae6f88381a41942 Mon Sep 17 00:00:00 2001
From: cdchen-ca <cdchen at ca.ibm.com>
Date: Fri, 26 Jan 2024 14:31:36 -0500
Subject: [PATCH 11/15] [Flang] Check ptrTy is not null before referencing it.

---
 flang/lib/Optimizer/Builder/IntrinsicCall.cpp | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/flang/lib/Optimizer/Builder/IntrinsicCall.cpp b/flang/lib/Optimizer/Builder/IntrinsicCall.cpp
index 045e54deebaab3..552f5e93bd3807 100644
--- a/flang/lib/Optimizer/Builder/IntrinsicCall.cpp
+++ b/flang/lib/Optimizer/Builder/IntrinsicCall.cpp
@@ -2159,7 +2159,8 @@ IntrinsicLibrary::genAssociated(mlir::Type resultType,
                                 llvm::ArrayRef<fir::ExtendedValue> args) {
   assert(args.size() == 2);
   mlir::Type ptrTy = fir::getBase(args[0]).getType();
-  if (fir::isBoxProcAddressType(ptrTy) || ptrTy.isa<fir::BoxProcType>()) {
+  if (ptrTy &&
+      (fir::isBoxProcAddressType(ptrTy) || ptrTy.isa<fir::BoxProcType>())) {
     mlir::Value pointerBoxProc =
         fir::isBoxProcAddressType(ptrTy)
             ? builder.create<fir::LoadOp>(loc, fir::getBase(args[0]))

>From 69177e07b421a02455c7ac87865d5f04d2219f7c Mon Sep 17 00:00:00 2001
From: cdchen-ca <cdchen at ca.ibm.com>
Date: Fri, 26 Jan 2024 14:36:57 -0500
Subject: [PATCH 12/15] [Flang] Fixing code format.

---
 flang/lib/Lower/CallInterface.cpp | 9 ++++-----
 1 file changed, 4 insertions(+), 5 deletions(-)

diff --git a/flang/lib/Lower/CallInterface.cpp b/flang/lib/Lower/CallInterface.cpp
index bc81b40a53885a..59c5765b69d6bf 100644
--- a/flang/lib/Lower/CallInterface.cpp
+++ b/flang/lib/Lower/CallInterface.cpp
@@ -1131,12 +1131,11 @@ class Fortran::lower::CallInterfaceImpl {
             getBounds(*typeAndShape))
       mlirType = fir::SequenceType::get(*bounds, mlirType);
     if (result.attrs.test(Attr::Allocatable))
-      mlirType = fir::wrapInClassOrBoxType(
-          fir::HeapType::get(mlirType), resIsPolymorphic, resIsAssumedType);
+      mlirType = fir::wrapInClassOrBoxType(fir::HeapType::get(mlirType),
+                                           resIsPolymorphic, resIsAssumedType);
     if (result.attrs.test(Attr::Pointer))
-      mlirType =
-          fir::wrapInClassOrBoxType(fir::PointerType::get(mlirType),
-                                    resIsPolymorphic, resIsAssumedType);
+      mlirType = fir::wrapInClassOrBoxType(fir::PointerType::get(mlirType),
+                                           resIsPolymorphic, resIsAssumedType);
 
     if (fir::isa_char(mlirType)) {
       // Character scalar results must be passed as arguments in lowering so

>From 30ed1deb1988699f4c8c62707d89104b82aca6c8 Mon Sep 17 00:00:00 2001
From: cdchen-ca <cdchen at ca.ibm.com>
Date: Sat, 27 Jan 2024 12:15:05 -0500
Subject: [PATCH 13/15] [Flang] Address review comments.

---
 flang/lib/Lower/CallInterface.cpp | 2 +-
 flang/lib/Lower/ConvertCall.cpp   | 5 +----
 2 files changed, 2 insertions(+), 5 deletions(-)

diff --git a/flang/lib/Lower/CallInterface.cpp b/flang/lib/Lower/CallInterface.cpp
index 59c5765b69d6bf..46e5639918b256 100644
--- a/flang/lib/Lower/CallInterface.cpp
+++ b/flang/lib/Lower/CallInterface.cpp
@@ -371,7 +371,7 @@ bool Fortran::lower::CallerInterface::mustMapInterfaceSymbols() const {
   const std::optional<Fortran::evaluate::characteristics::FunctionResult>
       &result = characteristic->functionResult;
   if (!result || result->CanBeReturnedViaImplicitInterface() ||
-      !getInterfaceDetails())
+      !getInterfaceDetails() || result->IsProcedurePointer())
     return false;
   bool allResultSpecExprConstant = true;
   auto visitor = [&](const Fortran::lower::SomeExpr &e) {
diff --git a/flang/lib/Lower/ConvertCall.cpp b/flang/lib/Lower/ConvertCall.cpp
index ba0b4d4413e755..cd644192e0c634 100644
--- a/flang/lib/Lower/ConvertCall.cpp
+++ b/flang/lib/Lower/ConvertCall.cpp
@@ -158,8 +158,7 @@ fir::ExtendedValue Fortran::lower::genCallOpAndResult(
   bool mustPopSymMap = false;
 
   // Is procedure pointer functin result.
-  bool isProcedurePointer = resultType && resultType->isa<fir::BoxProcType>();
-  if (!isProcedurePointer && caller.mustMapInterfaceSymbols()) {
+  if (caller.mustMapInterfaceSymbols()) {
     symMap.pushScope();
     mustPopSymMap = true;
     Fortran::lower::mapCallInterfaceSymbols(converter, caller, symMap);
@@ -205,8 +204,6 @@ fir::ExtendedValue Fortran::lower::genCallOpAndResult(
     llvm::SmallVector<mlir::Value> lengths;
     if (!caller.callerAllocateResult())
       return {};
-    if (isProcedurePointer)
-      return {};
     mlir::Type type = caller.getResultStorageType();
     if (type.isa<fir::SequenceType>())
       caller.walkResultExtents([&](const Fortran::lower::SomeExpr &e) {

>From cc702b9619450e43e14e60ffe4679de51f445957 Mon Sep 17 00:00:00 2001
From: cdchen-ca <cdchen at ca.ibm.com>
Date: Mon, 29 Jan 2024 11:52:51 -0500
Subject: [PATCH 14/15] [Flang] Minor clean up.

---
 flang/lib/Lower/ConvertCall.cpp | 3 ---
 1 file changed, 3 deletions(-)

diff --git a/flang/lib/Lower/ConvertCall.cpp b/flang/lib/Lower/ConvertCall.cpp
index cd644192e0c634..1d5ebeb1b3620e 100644
--- a/flang/lib/Lower/ConvertCall.cpp
+++ b/flang/lib/Lower/ConvertCall.cpp
@@ -156,8 +156,6 @@ fir::ExtendedValue Fortran::lower::genCallOpAndResult(
   using PassBy = Fortran::lower::CallerInterface::PassEntityBy;
   // Handle cases where caller must allocate the result or a fir.box for it.
   bool mustPopSymMap = false;
-
-  // Is procedure pointer functin result.
   if (caller.mustMapInterfaceSymbols()) {
     symMap.pushScope();
     mustPopSymMap = true;
@@ -448,7 +446,6 @@ fir::ExtendedValue Fortran::lower::genCallOpAndResult(
       callResult = call.getResult(0);
   }
 
-  // if (!isProcedurePointer && caller.mustSaveResult()) {
   if (caller.mustSaveResult()) {
     assert(allocatedResult.has_value());
     builder.create<fir::SaveResultOp>(loc, callResult,

>From 0f8bea5aebc3ac0b1ac6ade28920c3ffbe8433c7 Mon Sep 17 00:00:00 2001
From: cdchen-ca <cdchen at ca.ibm.com>
Date: Mon, 29 Jan 2024 12:24:24 -0500
Subject: [PATCH 15/15] [Flang] To address review comment to correct the
 resultType.

---
 flang/lib/Lower/ConvertExprToHLFIR.cpp | 7 +++----
 1 file changed, 3 insertions(+), 4 deletions(-)

diff --git a/flang/lib/Lower/ConvertExprToHLFIR.cpp b/flang/lib/Lower/ConvertExprToHLFIR.cpp
index 76b8e16e7767c2..ba3acd8bba5f81 100644
--- a/flang/lib/Lower/ConvertExprToHLFIR.cpp
+++ b/flang/lib/Lower/ConvertExprToHLFIR.cpp
@@ -1433,12 +1433,11 @@ class HlfirBuilder {
   }
 
   hlfir::EntityWithAttributes gen(const Fortran::evaluate::ProcedureRef &expr) {
-    fir::FirOpBuilder &builder = getBuilder();
     Fortran::evaluate::ProcedureDesignator proc{expr.proc()};
     auto procTy{Fortran::lower::translateSignature(proc, getConverter())};
-    mlir::Type resType = fir::BoxProcType::get(builder.getContext(), procTy);
-    auto result = Fortran::lower::convertCallToHLFIR(
-        getLoc(), getConverter(), expr, resType, getSymMap(), getStmtCtx());
+    auto result = Fortran::lower::convertCallToHLFIR(getLoc(), getConverter(),
+                                                     expr, procTy.getResult(0),
+                                                     getSymMap(), getStmtCtx());
     assert(result.has_value());
     return *result;
   }



More information about the flang-commits mailing list