[flang] Lower statement function

[clementval]

Summary

This patch adds lowering to suppoert statement functions

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

[PeteSteinfeld]

All builds and tests correctly and looks good.

flang/include/flang/Optimizer/Dialect/FIRType.h

 #ifndef NDEBUG
 // !fir.ptr<X> and !fir.heap<X> where X is !fir.ptr, !fir.heap, or !fir.ref
 // is undefined and disallowed.
 inline bool singleIndirectionLevel(mlir::Type ty) {
   return !fir::isa_ref_type(ty);
 }
 #endif
 
+/// Return true iff `ty` is the type of a POINTER entity or value.
+/// `isa_ref_type()` can be used to distinguish.
+bool isPointerType(mlir::Type ty);
+
 /// Return true iff `ty` is the type of an ALLOCATABLE entity or value.
 bool isAllocatableType(mlir::Type ty);
 
 /// Return true iff `ty` is a RecordType with members that are allocatable.
 bool isRecordWithAllocatableMember(mlir::Type ty);
 
 /// Return true iff `ty` is a RecordType with type parameters.
 inline bool isRecordWithTypeParameters(mlir::Type ty) {

flang/lib/Lower/ConvertExpr.cpp

if (dt.category() != Fortran::common::TypeCategory::Derived)
       return converter.genType(dt.category(), dt.kind());
     return converter.genType(dt.GetDerivedTypeSpec());
   }
 
   /// Lower a function reference
   template <typename A>
   ExtValue genFunctionRef(const Fortran::evaluate::FunctionRef<A> &funcRef) {
     if (!funcRef.GetType().has_value())
-      fir::emitFatalError(getLoc(), "internal: a function must have a type");
+      fir::emitFatalError(getLoc(), "a function must have a type");
     mlir::Type resTy = genType(*funcRef.GetType());
     return genProcedureRef(funcRef, {resTy});
   }
 
   /// Lower function call `funcRef` and return a reference to the resultant
   /// value. This is required for lowering expressions such as `f1(f2(v))`.
   template <typename A>
   ExtValue gen(const Fortran::evaluate::FunctionRef<A> &funcRef) {
     ExtValue retVal = genFunctionRef(funcRef);
-    mlir::Value retValBase = fir::getBase(retVal);
-    if (fir::conformsWithPassByRef(retValBase.getType()))
-      return retVal;
-    auto mem = builder.create<fir::AllocaOp>(getLoc(), retValBase.getType());
-    builder.create<fir::StoreOp>(getLoc(), retValBase, mem);
-    return fir::substBase(retVal, mem.getResult());
+    mlir::Type resultType = converter.genType(toEvExpr(funcRef));
+    return placeScalarValueInMemory(builder, getLoc(), retVal, resultType);
   }
 
   /// helper to detect statement functions
   static bool
   isStatementFunctionCall(const Fortran::evaluate::ProcedureRef &procRef) {
     if (const Fortran::semantics::Symbol *symbol = procRef.proc().GetSymbol())
       if (const auto *details =
               symbol->detailsIf<Fortran::semantics::SubprogramDetails>())
for (const Fortran::lower::CallInterface<
                  "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;
         }
+        if (fir::isPointerType(argTy) &&
+            !Fortran::evaluate::IsObjectPointer(
+                *expr, converter.getFoldingContext())) {
+          // Passing a non POINTER actual argument to a POINTER dummy argument.
+          // Create a pointer of the dummy argument type and assign the actual
+          // argument to it.
+          mlir::Value irBox =
+              builder.createTemporary(loc, fir::unwrapRefType(argTy));
+          // Non deferred parameters will be evaluated on the callee side.
+          fir::MutableBoxValue pointer(irBox,
+                                       /*nonDeferredParams=*/mlir::ValueRange{},
+                                       /*mutableProperties=*/{});
+          Fortran::lower::associateMutableBox(converter, loc, pointer, *expr,
+                                              /*lbounds*/ mlir::ValueRange{},
+                                              stmtCtx);
+          caller.placeInput(arg, irBox);
+          continue;
+        }
+        // Passing a POINTER to a POINTER, or an ALLOCATABLE to an ALLOCATABLE.
         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;
       }

flang/lib/Optimizer/Dialect/FIRType.cpp

bool hasDynamicSize(mlir::Type t) {
   }
   if (characterWithDynamicLen(t))
     return true;
   if (auto rec = t.dyn_cast<fir::RecordType>())
     return hasDynamicSize(rec);
   return false;
 }
 
+bool isPointerType(mlir::Type ty) {
+  if (auto refTy = fir::dyn_cast_ptrEleTy(ty))
+    ty = refTy;
+  if (auto boxTy = ty.dyn_cast<fir::BoxType>())
+    return boxTy.getEleTy().isa<fir::PointerType>();
+  return false;
+}
+
 bool isAllocatableType(mlir::Type ty) {
   if (auto refTy = fir::dyn_cast_ptrEleTy(ty))
     ty = refTy;
   if (auto boxTy = ty.dyn_cast<fir::BoxType>())
     return boxTy.getEleTy().isa<fir::HeapType>();
   return false;
 }
 

flang/test/Lower/statement-function.f90

+! RUN: bbc -emit-fir -outline-intrinsics %s -o - | FileCheck %s
+
+! Test statement function lowering
+
+! Simple case
+  ! CHECK-LABEL: func @_QPtest_stmt_0(
+  ! CHECK-SAME: %{{.*}}: !fir.ref<f32>{{.*}}) -> f32
+real function test_stmt_0(x)
+real :: x, func, arg
+func(arg) = arg + 0.123456
+
+! CHECK-DAG: %[[x:.*]] = fir.load %arg0
+! CHECK-DAG: %[[cst:.*]] = arith.constant 1.234560e-01
+! CHECK: %[[eval:.*]] = arith.addf %[[x]], %[[cst]]
+! CHECK: fir.store %[[eval]] to %[[resmem:.*]] : !fir.ref<f32>
+test_stmt_0 = func(x)
+
+! CHECK: %[[res:.*]] = fir.load %[[resmem]]
+! CHECK: return %[[res]]
+end function
+
+! Check this is not lowered as a simple macro: e.g. argument is only
+! evaluated once even if it appears in several placed inside the
+! statement function expression 
+! CHECK-LABEL: func @_QPtest_stmt_only_eval_arg_once() -> f32
+real(4) function test_stmt_only_eval_arg_once()
+real(4) :: only_once, x1
+func(x1) = x1 + x1
+! CHECK: %[[x2:.*]] = fir.alloca f32 {adapt.valuebyref}
+! CHECK: %[[x1:.*]] = fir.call @_QPonly_once()
+! Note: using -emit-fir, so the faked pass-by-reference is exposed
+! CHECK: fir.store %[[x1]] to %[[x2]]
+! CHECK: addf %{{.*}}, %{{.*}}
+test_stmt_only_eval_arg_once = func(only_once())
+end function
+
+! Test nested statement function (note that they cannot be recursively
+! nested as per F2018 C1577).
+real function test_stmt_1(x, a)
+real :: y, a, b, foo
+real :: func1, arg1, func2, arg2
+real :: res1, res2
+func1(arg1) = a + foo(arg1)
+func2(arg2) = func1(arg2) + b
+! CHECK-DAG: %[[bmem:.*]] = fir.alloca f32 {{{.*}}uniq_name = "{{.*}}Eb"}
+! CHECK-DAG: %[[res1:.*]] = fir.alloca f32 {{{.*}}uniq_name = "{{.*}}Eres1"}
+! CHECK-DAG: %[[res2:.*]] = fir.alloca f32 {{{.*}}uniq_name = "{{.*}}Eres2"}
+
+b = 5
+
+! CHECK-DAG: %[[cst_8:.*]] = arith.constant 8.000000e+00
+! CHECK-DAG: fir.store %[[cst_8]] to %[[tmp1:.*]] : !fir.ref<f32>
+! CHECK-DAG: %[[foocall1:.*]] = fir.call @_QPfoo(%[[tmp1]])
+! CHECK-DAG: %[[aload1:.*]] = fir.load %arg1
+! CHECK: %[[add1:.*]] = arith.addf %[[aload1]], %[[foocall1]]
+! CHECK: fir.store %[[add1]] to %[[res1]]
+res1 =  func1(8.)
+
+! CHECK-DAG: %[[a2:.*]] = fir.load %arg1
+! CHECK-DAG: %[[foocall2:.*]] = fir.call @_QPfoo(%arg0)
+! CHECK-DAG: %[[add2:.*]] = arith.addf %[[a2]], %[[foocall2]]
+! CHECK-DAG: %[[b:.*]] = fir.load %[[bmem]]
+! CHECK: %[[add3:.*]] = arith.addf %[[add2]], %[[b]]
+! CHECK: fir.store %[[add3]] to %[[res2]]
+res2 = func2(x)
+
+! CHECK-DAG: %[[res12:.*]] = fir.load %[[res1]]
+! CHECK-DAG: %[[res22:.*]] = fir.load %[[res2]]
+! CHECK: = arith.addf %[[res12]], %[[res22]] : f32
+test_stmt_1 = res1 + res2
+! CHECK: return %{{.*}} : f32
+end function
+
+
+! Test statement functions with no argument.
+! Test that they are not pre-evaluated.
+! CHECK-LABEL: func @_QPtest_stmt_no_args
+real function test_stmt_no_args(x, y)
+func() = x + y
+! CHECK: addf
+a = func()
+! CHECK: fir.call @_QPfoo_may_modify_xy
+call foo_may_modify_xy(x, y)
+! CHECK: addf
+! CHECK: addf
+test_stmt_no_args = func() + a
+end function
+
+! Test statement function with character arguments
+! CHECK-LABEL: @_QPtest_stmt_character
+integer function test_stmt_character(c, j)
+ integer :: i, j, func, argj
+ character(10) :: c, argc
+ ! CHECK-DAG: %[[unboxed:.*]]:2 = fir.unboxchar %arg0 :
+ ! CHECK-DAG: %[[c10:.*]] = arith.constant 10 :
+ ! CHECK: %[[c10_cast:.*]] = fir.convert %[[c10]] : (i32) -> index
+ ! CHECK: %[[c:.*]] = fir.emboxchar %[[unboxed]]#0, %[[c10_cast]]
+
+ func(argc, argj) = len_trim(argc, 4) + argj
+ ! CHECK: addi %{{.*}}, %{{.*}} : i
+ test_stmt_character = func(c, j)
+end function
+
+! Test statement function with a character actual argument whose
+! length may be different than the dummy length (the dummy length
+! must be used inside the statement function).
+! CHECK-LABEL: @_QPtest_stmt_character_with_different_length(
+! CHECK-SAME: %[[arg0:.*]]: !fir.boxchar<1>
+integer function test_stmt_character_with_different_length(c)
+ integer :: func, ifoo
+ character(10) :: argc
+ character(*) :: c
+ ! CHECK-DAG: %[[unboxed:.*]]:2 = fir.unboxchar %[[arg0]] :
+ ! CHECK-DAG: %[[c10:.*]] = arith.constant 10 :
+ ! CHECK: %[[c10_cast:.*]] = fir.convert %[[c10]] : (i32) -> index
+ ! CHECK: %[[argc:.*]] = fir.emboxchar %[[unboxed]]#0, %[[c10_cast]]
+ ! CHECK: fir.call @_QPifoo(%[[argc]]) : (!fir.boxchar<1>) -> i32
+ func(argc) = ifoo(argc)
+ test_stmt_character = func(c)
+end function
+
+! CHECK-LABEL: @_QPtest_stmt_character_with_different_length_2(
+! CHECK-SAME: %[[arg0:.*]]: !fir.boxchar<1>{{.*}}, %[[arg1:.*]]: !fir.ref<i32>
+integer function test_stmt_character_with_different_length_2(c, n)
+ integer :: func, ifoo
+ character(n) :: argc
+ character(*) :: c
+ ! CHECK: %[[unboxed:.*]]:2 = fir.unboxchar %[[arg0]] :
+ ! CHECK: fir.load %[[arg1]] : !fir.ref<i32>
+ ! CHECK: %[[n:.*]] = fir.load %[[arg1]] : !fir.ref<i32>
+ ! CHECK: %[[n_is_positive:.*]] = arith.cmpi sgt, %[[n]], %c0{{.*}} : i32
+ ! CHECK: %[[len:.*]] = arith.select %[[n_is_positive]], %[[n]], %c0{{.*}} : i32
+ ! CHECK: %[[lenCast:.*]] = fir.convert %[[len]] : (i32) -> index
+ ! CHECK: %[[argc:.*]] = fir.emboxchar %[[unboxed]]#0, %[[lenCast]] : (!fir.ref<!fir.char<1,?>>, index) -> !fir.boxchar<1>
+ ! CHECK: fir.call @_QPifoo(%[[argc]]) : (!fir.boxchar<1>) -> i32
+ func(argc) = ifoo(argc)
+ test_stmt_character = func(c)
+end function
+
+! issue #247
+! CHECK-LABEL: @_QPbug247
+subroutine bug247(r)
+I(R) = R
+! CHECK: fir.call {{.*}}OutputInteger
+PRINT *, I(2.5)
+! CHECK: fir.call {{.*}}EndIo
+END subroutine bug247