diff --git a/flang/include/flang/Optimizer/Dialect/FIRType.h b/flang/include/flang/Optimizer/Dialect/FIRType.h --- a/flang/include/flang/Optimizer/Dialect/FIRType.h +++ b/flang/include/flang/Optimizer/Dialect/FIRType.h @@ -191,6 +191,10 @@ } #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); diff --git a/flang/lib/Lower/ConvertExpr.cpp b/flang/lib/Lower/ConvertExpr.cpp --- a/flang/lib/Lower/ConvertExpr.cpp +++ b/flang/lib/Lower/ConvertExpr.cpp @@ -1826,7 +1826,7 @@ template ExtValue genFunctionRef(const Fortran::evaluate::FunctionRef &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}); } @@ -1836,12 +1836,8 @@ template ExtValue gen(const Fortran::evaluate::FunctionRef &funcRef) { ExtValue retVal = genFunctionRef(funcRef); - mlir::Value retValBase = fir::getBase(retVal); - if (fir::conformsWithPassByRef(retValBase.getType())) - return retVal; - auto mem = builder.create(getLoc(), retValBase.getType()); - builder.create(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 @@ -2457,6 +2453,25 @@ 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); diff --git a/flang/lib/Optimizer/Dialect/FIRType.cpp b/flang/lib/Optimizer/Dialect/FIRType.cpp --- a/flang/lib/Optimizer/Dialect/FIRType.cpp +++ b/flang/lib/Optimizer/Dialect/FIRType.cpp @@ -246,6 +246,14 @@ return false; } +bool isPointerType(mlir::Type ty) { + if (auto refTy = fir::dyn_cast_ptrEleTy(ty)) + ty = refTy; + if (auto boxTy = ty.dyn_cast()) + return boxTy.getEleTy().isa(); + return false; +} + bool isAllocatableType(mlir::Type ty) { if (auto refTy = fir::dyn_cast_ptrEleTy(ty)) ty = refTy; diff --git a/flang/test/Lower/statement-function.f90 b/flang/test/Lower/statement-function.f90 new file mode 100644 --- /dev/null +++ b/flang/test/Lower/statement-function.f90 @@ -0,0 +1,147 @@ +! 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 +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 +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 +! 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 +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 + ! CHECK: %[[n:.*]] = fir.load %[[arg1]] : !fir.ref + ! 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>, 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