[flang-commits] [flang] 4d95f74 - [flang] Lower assumed length character allocatable and pointer arguments
Jonathon Penix via flang-commits
flang-commits at lists.llvm.org
Thu Oct 13 11:06:57 PDT 2022
Author: Jonathon Penix
Date: 2022-10-13T11:03:56-07:00
New Revision: 4d95f74b13c6149a8ee2dfa0412d992c613c0c89
URL: https://github.com/llvm/llvm-project/commit/4d95f74b13c6149a8ee2dfa0412d992c613c0c89
DIFF: https://github.com/llvm/llvm-project/commit/4d95f74b13c6149a8ee2dfa0412d992c613c0c89.diff
LOG: [flang] Lower assumed length character allocatable and pointer arguments
It seems the needed functionality was already implemented for host associations,
so turn that code into a function and move it into a (hopefully appropriate)
common location and reuse it.
Differential Revision: https://reviews.llvm.org/D135481
Added:
flang/test/Lower/pointer-args-callee.f90
Modified:
flang/include/flang/Lower/Allocatable.h
flang/lib/Lower/Allocatable.cpp
flang/lib/Lower/ConvertVariable.cpp
flang/lib/Lower/HostAssociations.cpp
flang/test/Lower/allocatable-callee.f90
Removed:
################################################################################
diff --git a/flang/include/flang/Lower/Allocatable.h b/flang/include/flang/Lower/Allocatable.h
index 7776f0455d34a..2da24dcadee76 100644
--- a/flang/include/flang/Lower/Allocatable.h
+++ b/flang/include/flang/Lower/Allocatable.h
@@ -33,6 +33,10 @@ struct AllocateStmt;
struct DeallocateStmt;
} // namespace parser
+namespace semantics {
+class Symbol;
+} // namespace semantics
+
namespace lower {
struct SymbolBox;
@@ -75,6 +79,12 @@ bool isWholeAllocatable(const SomeExpr &expr);
/// Is \p expr a reference to an entity with the POINTER attribute?
bool isWholePointer(const SomeExpr &expr);
+/// Read the length from \p box for an assumed length character allocatable or
+/// pointer dummy argument given by \p sym.
+mlir::Value getAssumedCharAllocatableOrPointerLen(
+ fir::FirOpBuilder &builder, mlir::Location loc,
+ const Fortran::semantics::Symbol &sym, mlir::Value box);
+
} // namespace lower
} // namespace Fortran
diff --git a/flang/lib/Lower/Allocatable.cpp b/flang/lib/Lower/Allocatable.cpp
index 5fe4dfad32c75..5fda1f27475a1 100644
--- a/flang/lib/Lower/Allocatable.cpp
+++ b/flang/lib/Lower/Allocatable.cpp
@@ -725,3 +725,36 @@ bool Fortran::lower::isWholePointer(const Fortran::lower::SomeExpr &expr) {
return Fortran::semantics::IsPointer(*sym);
return false;
}
+
+mlir::Value Fortran::lower::getAssumedCharAllocatableOrPointerLen(
+ fir::FirOpBuilder &builder, mlir::Location loc,
+ const Fortran::semantics::Symbol &sym, mlir::Value box) {
+ // Read length from fir.box (explicit expr cannot safely be re-evaluated
+ // here).
+ auto readLength = [&]() {
+ fir::BoxValue boxLoad =
+ builder.create<fir::LoadOp>(loc, fir::getBase(box)).getResult();
+ return fir::factory::readCharLen(builder, loc, boxLoad);
+ };
+ if (Fortran::semantics::IsOptional(sym)) {
+ mlir::IndexType idxTy = builder.getIndexType();
+ // It is not safe to unconditionally read boxes of optionals in case
+ // they are absents. According to 15.5.2.12 3 (9), it is illegal to
+ // inquire the length of absent optional, even if non deferred, so
+ // it's fine to use undefOp in this case.
+ auto isPresent = builder.create<fir::IsPresentOp>(loc, builder.getI1Type(),
+ fir::getBase(box));
+ mlir::Value len =
+ builder.genIfOp(loc, {idxTy}, isPresent, true)
+ .genThen(
+ [&]() { builder.create<fir::ResultOp>(loc, readLength()); })
+ .genElse([&]() {
+ auto undef = builder.create<fir::UndefOp>(loc, idxTy);
+ builder.create<fir::ResultOp>(loc, undef.getResult());
+ })
+ .getResults()[0];
+ return len;
+ }
+
+ return readLength();
+}
diff --git a/flang/lib/Lower/ConvertVariable.cpp b/flang/lib/Lower/ConvertVariable.cpp
index 32722ab7a4845..363526ac667de 100644
--- a/flang/lib/Lower/ConvertVariable.cpp
+++ b/flang/lib/Lower/ConvertVariable.cpp
@@ -1351,7 +1351,9 @@ void Fortran::lower::mapSymbolAttributes(
lowerExplicitCharLen(converter, loc, ba, symMap, stmtCtx))
nonDeferredLenParams.push_back(len);
else if (Fortran::semantics::IsAssumedLengthCharacter(sym))
- TODO(loc, "assumed length character allocatable");
+ nonDeferredLenParams.push_back(
+ Fortran::lower::getAssumedCharAllocatableOrPointerLen(
+ builder, loc, sym, boxAlloc));
} else if (const Fortran::semantics::DeclTypeSpec *declTy = sym.GetType()) {
if (const Fortran::semantics::DerivedTypeSpec *derived =
declTy->AsDerived())
diff --git a/flang/lib/Lower/HostAssociations.cpp b/flang/lib/Lower/HostAssociations.cpp
index 8b2699939de24..d1145da63cd43 100644
--- a/flang/lib/Lower/HostAssociations.cpp
+++ b/flang/lib/Lower/HostAssociations.cpp
@@ -270,35 +270,9 @@ class CapturedAllocatableAndPointer
builder.createIntegerConstant(loc, idxTy, *len));
} else if (Fortran::semantics::IsAssumedLengthCharacter(sym) ||
ba.getCharLenExpr()) {
- // Read length from fir.box (explicit expr cannot safely be re-evaluated
- // here).
- auto readLength = [&]() {
- fir::BoxValue boxLoad =
- builder.create<fir::LoadOp>(loc, fir::getBase(args.valueInTuple))
- .getResult();
- return fir::factory::readCharLen(builder, loc, boxLoad);
- };
- if (Fortran::semantics::IsOptional(sym)) {
- // It is not safe to unconditionally read boxes of optionals in case
- // they are absents. According to 15.5.2.12 3 (9), it is illegal to
- // inquire the length of absent optional, even if non deferred, so
- // it's fine to use undefOp in this case.
- auto isPresent = builder.create<fir::IsPresentOp>(
- loc, builder.getI1Type(), fir::getBase(args.valueInTuple));
- mlir::Value len =
- builder.genIfOp(loc, {idxTy}, isPresent, true)
- .genThen([&]() {
- builder.create<fir::ResultOp>(loc, readLength());
- })
- .genElse([&]() {
- auto undef = builder.create<fir::UndefOp>(loc, idxTy);
- builder.create<fir::ResultOp>(loc, undef.getResult());
- })
- .getResults()[0];
- nonDeferredLenParams.push_back(len);
- } else {
- nonDeferredLenParams.push_back(readLength());
- }
+ nonDeferredLenParams.push_back(
+ Fortran::lower::getAssumedCharAllocatableOrPointerLen(
+ builder, loc, sym, args.valueInTuple));
}
} else if (isDerivedWithLenParameters(sym)) {
TODO(loc, "host associated derived type allocatable or pointer with "
diff --git a/flang/test/Lower/allocatable-callee.f90 b/flang/test/Lower/allocatable-callee.f90
index e5882f1a6d4dd..986ae81ecc058 100644
--- a/flang/test/Lower/allocatable-callee.f90
+++ b/flang/test/Lower/allocatable-callee.f90
@@ -142,3 +142,40 @@ subroutine test_char_scalar_deferred_k2(c)
! CHECK: %[[boxchar:.*]] = fir.emboxchar %[[addr_cast]], %[[len]] : (!fir.ref<!fir.char<2,?>>, index) -> !fir.boxchar<2>
! CHECK: fir.call @_QPfoo2(%[[boxchar]]) : (!fir.boxchar<2>) -> ()
end subroutine
+
+! Check that assumed length character allocatables are reading the length from
+! the descriptor.
+
+! CHECK-LABEL: _QPtest_char_assumed(
+! CHECK-SAME: %[[arg0:.*]]: !fir.ref<!fir.box<!fir.heap<!fir.char<1,?>>>>{{.*}}
+subroutine test_char_assumed(a)
+ integer :: n
+ character(len=*), allocatable :: a
+ ! CHECK: %[[argLoad:.*]] = fir.load %[[arg0]] : !fir.ref<!fir.box<!fir.heap<!fir.char<1,?>>>>
+ ! CHECK: %[[argLen:.*]] = fir.box_elesize %[[argLoad]] : (!fir.box<!fir.heap<!fir.char<1,?>>>) -> index
+
+ n = len(a)
+ ! CHECK: %[[argLenCast:.*]] = fir.convert %[[argLen]] : (index) -> i32
+ ! CHECK: fir.store %[[argLenCast]] to %{{.*}} : !fir.ref<i32>
+end subroutine
+
+! CHECK-LABEL: _QPtest_char_assumed_optional(
+! CHECK-SAME: %[[arg0:.*]]: !fir.ref<!fir.box<!fir.heap<!fir.char<1,?>>>>{{.*}}
+subroutine test_char_assumed_optional(a)
+ integer :: n
+ character(len=*), allocatable, optional :: a
+ ! CHECK: %[[argPresent:.*]] = fir.is_present %[[arg0]] : (!fir.ref<!fir.box<!fir.heap<!fir.char<1,?>>>>) -> i1
+ ! CHECK: %[[argLen:.*]] = fir.if %[[argPresent]] -> (index) {
+ ! CHECK: %[[argLoad:.*]] = fir.load %[[arg0]] : !fir.ref<!fir.box<!fir.heap<!fir.char<1,?>>>>
+ ! CHECK: %[[argEleSz:.*]] = fir.box_elesize %[[argLoad]] : (!fir.box<!fir.heap<!fir.char<1,?>>>) -> index
+ ! CHECK: fir.result %[[argEleSz]] : index
+ ! CHECK: } else {
+ ! CHECK: %[[undef:.*]] = fir.undefined index
+ ! CHECK: fir.result %[[undef]] : index
+
+ if (present(a)) then
+ n = len(a)
+ ! CHECK: %[[argLenCast:.*]] = fir.convert %[[argLen]] : (index) -> i32
+ ! CHECK: fir.store %[[argLenCast]] to %{{.*}} : !fir.ref<i32>
+ endif
+end subroutine
diff --git a/flang/test/Lower/pointer-args-callee.f90 b/flang/test/Lower/pointer-args-callee.f90
new file mode 100755
index 0000000000000..531f6b6969472
--- /dev/null
+++ b/flang/test/Lower/pointer-args-callee.f90
@@ -0,0 +1,37 @@
+! Test calls with POINTER dummy arguments on the callee side.
+! RUN: bbc -emit-fir %s -o - | FileCheck %s
+
+! CHECK-LABEL: func @_QPchar_assumed(
+! CHECK-SAME: %[[arg0:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.char<1,?>>>>{{.*}}
+subroutine char_assumed(a)
+ integer :: n
+ character(len=*), pointer :: a
+ ! CHECK: %[[argLoad:.*]] = fir.load %[[arg0]] : !fir.ref<!fir.box<!fir.ptr<!fir.char<1,?>>>>
+ ! CHECK: %[[argLen:.*]] = fir.box_elesize %[[argLoad]] : (!fir.box<!fir.ptr<!fir.char<1,?>>>) -> index
+
+ n = len(a)
+ ! CHECK: %[[argLenCast:.*]] = fir.convert %[[argLen]] : (index) -> i32
+ ! CHECK: fir.store %[[argLenCast]] to %{{.*}} : !fir.ref<i32>
+end subroutine
+
+! CHECK-LABEL: func @_QPchar_assumed_optional(
+! CHECK-SAME: %[[arg0:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.char<1,?>>>>{{.*}}
+subroutine char_assumed_optional(a)
+ integer :: n
+ character(len=*), pointer, optional :: a
+ ! CHECK: %[[argPresent:.*]] = fir.is_present %[[arg0]] : (!fir.ref<!fir.box<!fir.ptr<!fir.char<1,?>>>>) -> i1
+ ! CHECK: %[[argLen:.*]] = fir.if %[[argPresent]] -> (index) {
+ ! CHECK: %[[argLoad:.*]] = fir.load %[[arg0]] : !fir.ref<!fir.box<!fir.ptr<!fir.char<1,?>>>>
+ ! CHECK: %[[argLoadLen:.*]] = fir.box_elesize %[[argLoad]] : (!fir.box<!fir.ptr<!fir.char<1,?>>>) -> index
+ ! CHECK: fir.result %[[argLoadLen]] : index
+ ! CHECK: } else {
+ ! CHECK: %[[undef:.*]] = fir.undefined index
+ ! CHECK: fir.result %[[undef]] : index
+ ! CHECK: }
+
+ if (present(a)) then
+ n = len(a)
+ ! CHECK: %[[argLenCast:.*]] = fir.convert %[[argLen]] : (index) -> i32
+ ! CHECK: fir.store %[[argLenCast]] to %{{.*}} : !fir.ref<i32>
+ endif
+end subroutine
More information about the flang-commits
mailing list