[flang] Add test for allocatable on the caller side

This patch adds test for allocatable on the caller side.
Lowering for missing features is added as well.

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

Depends on D120746

Reviewed By: PeteSteinfeld, schweitz

Differential Revision: https://reviews.llvm.org/D120748

Co-authored-by: Eric Schweitz <eschweitz@nvidia.com>
Co-authored-by: Jean Perier <jperier@nvidia.com>

diff --git a/flang/lib/Lower/ConvertExpr.cpp b/flang/lib/Lower/ConvertExpr.cpp
index d0dd4bb..7d4a4d0 100644 (file)
--- a/flang/lib/Lower/ConvertExpr.cpp
+++ b/flang/lib/Lower/ConvertExpr.cpp
@@ -1443,7 +1443,32 @@ public:
       }
 
       if (arg.passBy == PassBy::MutableBox) {
-        TODO(loc, "arg passby MutableBox");
+        if (Fortran::evaluate::UnwrapExpr<Fortran::evaluate::NullPointer>(
+                *expr)) {
+          // If expr is NULL(), the mutableBox created must be a deallocated
+          // pointer with the dummy argument characteristics (see table 16.5
+          // in Fortran 2018 standard).
+          // No length parameters are set for the created box because any non
+          // deferred type parameters of the dummy will be evaluated on the
+          // callee side, and it is illegal to use NULL without a MOLD if any
+          // dummy length parameters are assumed.
+          mlir::Type boxTy = fir::dyn_cast_ptrEleTy(argTy);
+          assert(boxTy && boxTy.isa<fir::BoxType>() &&
+                 "must be a fir.box type");
+          mlir::Value boxStorage = builder.createTemporary(loc, boxTy);
+          mlir::Value nullBox = fir::factory::createUnallocatedBox(
+              builder, loc, boxTy, /*nonDeferredParams=*/{});
+          builder.create<fir::StoreOp>(loc, nullBox, boxStorage);
+          caller.placeInput(arg, boxStorage);
+          continue;
+        }
+        fir::MutableBoxValue mutableBox = genMutableBoxValue(*expr);
+        mlir::Value irBox =
+            fir::factory::getMutableIRBox(builder, loc, mutableBox);
+        caller.placeInput(arg, irBox);
+        if (arg.mayBeModifiedByCall())
+          mutableModifiedByCall.emplace_back(std::move(mutableBox));
+        continue;
       }
       const bool actualArgIsVariable = Fortran::evaluate::IsVariable(*expr);
       if (arg.passBy == PassBy::BaseAddress || arg.passBy == PassBy::BoxChar) {

diff --git a/flang/test/Lower/allocatable-caller.f90 b/flang/test/Lower/allocatable-caller.f90
new file mode 100644 (file)
index 0000000..16d661b
--- /dev/null
+++ b/flang/test/Lower/allocatable-caller.f90
@@ -0,0 +1,101 @@
+! RUN: bbc -emit-fir %s -o - | FileCheck %s
+
+! Test passing allocatables on caller side
+
+! CHECK-LABEL: func @_QPtest_scalar_call(
+subroutine test_scalar_call()
+  interface
+  subroutine test_scalar(x)
+    real, allocatable :: x
+  end subroutine
+  end interface
+  real, allocatable :: x
+  ! CHECK: %[[box:.*]] = fir.alloca !fir.box<!fir.heap<f32>> {{{.*}}uniq_name = "_QFtest_scalar_callEx"}
+  call test_scalar(x)
+  ! CHECK: fir.call @_QPtest_scalar(%[[box]]) : (!fir.ref<!fir.box<!fir.heap<f32>>>) -> ()
+end subroutine
+
+! CHECK-LABEL: func @_QPtest_array_call(
+subroutine test_array_call()
+  interface
+  subroutine test_array(x)
+    integer, allocatable :: x(:)
+  end subroutine
+  end interface
+  integer, allocatable :: x(:)
+  ! CHECK: %[[box:.*]] = fir.alloca !fir.box<!fir.heap<!fir.array<?xi32>>> {{{.*}}uniq_name = "_QFtest_array_callEx"}
+  call test_array(x)
+  ! CHECK: fir.call @_QPtest_array(%[[box]]) : (!fir.ref<!fir.box<!fir.heap<!fir.array<?xi32>>>>) -> ()
+end subroutine
+
+! CHECK-LABEL: func @_QPtest_char_scalar_deferred_call(
+subroutine test_char_scalar_deferred_call()
+  interface
+  subroutine test_char_scalar_deferred(x)
+    character(:), allocatable :: x
+  end subroutine
+  end interface
+  character(:), allocatable :: x
+  character(10), allocatable :: x2
+  ! CHECK-DAG: %[[box:.*]] = fir.alloca !fir.box<!fir.heap<!fir.char<1,?>>> {{{.*}}uniq_name = "_QFtest_char_scalar_deferred_callEx"}
+  ! CHECK-DAG: %[[box2:.*]] = fir.alloca !fir.box<!fir.heap<!fir.char<1,10>>> {{{.*}}uniq_name = "_QFtest_char_scalar_deferred_callEx2"}
+  call test_char_scalar_deferred(x)
+  ! CHECK: fir.call @_QPtest_char_scalar_deferred(%[[box]]) : (!fir.ref<!fir.box<!fir.heap<!fir.char<1,?>>>>) -> ()
+  call test_char_scalar_deferred(x2)
+  ! CHECK: %[[box2cast:.*]] = fir.convert %[[box2]] : (!fir.ref<!fir.box<!fir.heap<!fir.char<1,10>>>>) -> !fir.ref<!fir.box<!fir.heap<!fir.char<1,?>>>>
+  ! CHECK: fir.call @_QPtest_char_scalar_deferred(%[[box2cast]]) : (!fir.ref<!fir.box<!fir.heap<!fir.char<1,?>>>>) -> ()
+end subroutine
+
+! CHECK-LABEL: func @_QPtest_char_scalar_explicit_call(
+subroutine test_char_scalar_explicit_call()
+  interface
+  subroutine test_char_scalar_explicit(x)
+    character(10), allocatable :: x
+  end subroutine
+  end interface
+  character(10), allocatable :: x
+  character(:), allocatable :: x2
+  ! CHECK-DAG: %[[box:.*]] = fir.alloca !fir.box<!fir.heap<!fir.char<1,10>>> {{{.*}}uniq_name = "_QFtest_char_scalar_explicit_callEx"}
+  ! CHECK-DAG: %[[box2:.*]] = fir.alloca !fir.box<!fir.heap<!fir.char<1,?>>> {{{.*}}uniq_name = "_QFtest_char_scalar_explicit_callEx2"}
+  call test_char_scalar_explicit(x)
+  ! CHECK: fir.call @_QPtest_char_scalar_explicit(%[[box]]) : (!fir.ref<!fir.box<!fir.heap<!fir.char<1,10>>>>) -> ()
+  call test_char_scalar_explicit(x2)
+  ! CHECK: %[[box2cast:.*]] = fir.convert %[[box2]] : (!fir.ref<!fir.box<!fir.heap<!fir.char<1,?>>>>) -> !fir.ref<!fir.box<!fir.heap<!fir.char<1,10>>>>
+  ! CHECK: fir.call @_QPtest_char_scalar_explicit(%[[box2cast]]) : (!fir.ref<!fir.box<!fir.heap<!fir.char<1,10>>>>) -> ()
+end subroutine
+
+! CHECK-LABEL: func @_QPtest_char_array_deferred_call(
+subroutine test_char_array_deferred_call()
+  interface
+  subroutine test_char_array_deferred(x)
+    character(:), allocatable :: x(:)
+  end subroutine
+  end interface
+  character(:), allocatable :: x(:)
+  character(10), allocatable :: x2(:)
+  ! CHECK-DAG: %[[box:.*]] = fir.alloca !fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>> {{{.*}}uniq_name = "_QFtest_char_array_deferred_callEx"}
+  ! CHECK-DAG: %[[box2:.*]] = fir.alloca !fir.box<!fir.heap<!fir.array<?x!fir.char<1,10>>>> {{{.*}}uniq_name = "_QFtest_char_array_deferred_callEx2"}
+  call test_char_array_deferred(x)
+  ! CHECK: fir.call @_QPtest_char_array_deferred(%[[box]]) : (!fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>>) -> ()
+  call test_char_array_deferred(x2)
+  ! CHECK: %[[box2cast:.*]] = fir.convert %[[box2]] : (!fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,10>>>>>) -> !fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>>
+  ! CHECK: fir.call @_QPtest_char_array_deferred(%[[box2cast]]) : (!fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>>) -> ()
+end subroutine
+
+! CHECK-LABEL: func @_QPtest_char_array_explicit_call(
+subroutine test_char_array_explicit_call()
+  interface
+  subroutine test_char_array_explicit(x)
+    character(10), allocatable :: x(:)
+  end subroutine
+  end interface
+  character(10), allocatable :: x(:)
+  character(:), allocatable :: x2(:)
+  ! CHECK-DAG: %[[box:.*]] = fir.alloca !fir.box<!fir.heap<!fir.array<?x!fir.char<1,10>>>> {{{.*}}uniq_name = "_QFtest_char_array_explicit_callEx"}
+  ! CHECK-DAG: %[[box2:.*]] = fir.alloca !fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>> {{{.*}}uniq_name = "_QFtest_char_array_explicit_callEx2"}
+  call test_char_array_explicit(x)
+  ! CHECK: fir.call @_QPtest_char_array_explicit(%[[box]]) : (!fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,10>>>>>) -> ()
+  call test_char_array_explicit(x2)
+  ! CHECK: %[[box2cast:.*]] = fir.convert %[[box2]] : (!fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,?>>>>>) -> !fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,10>>>>>
+  ! CHECK: fir.call @_QPtest_char_array_explicit(%[[box2cast]]) : (!fir.ref<!fir.box<!fir.heap<!fir.array<?x!fir.char<1,10>>>>>) -> ()
+end subroutine