From 8c1270740f6bf659e5fbf556c1145ddaa7aa5366 Mon Sep 17 00:00:00 2001 From: jeanPerier Date: Thu, 28 Sep 2023 08:59:44 +0200 Subject: [PATCH] [flang] Fix issues with STORAGE_SIZE and characters (#67561) Semantics was replacing storage_size(func()) by the length specification expression of func result (if any), which brought meaningless symbols. Update FunctionRef::GetType to not copy its length parameter from the procedure designator symbol if it is not a constant expression. Note that the deferred aspect can and must be preserved because it matters for POINTER function results (semantics test added to ensure this). Update lowering code to deal with characters in storage_size: simply always call createBox to ensure the BoxEleSizeOp is legal. This will take care of dereferencing pointers/allocatables if needed (what the load was intended for in the previous code). --- flang/include/flang/Evaluate/call.h | 12 ++++++- flang/include/flang/Evaluate/type.h | 6 ++++ flang/lib/Evaluate/type.cpp | 11 +++++++ flang/lib/Optimizer/Builder/IntrinsicCall.cpp | 7 ++-- flang/test/Evaluate/rewrite06.f90 | 33 +++++++++++++++++++ .../test/Lower/Intrinsics/storage_size-2.f90 | 30 +++++++++++++++++ flang/test/Semantics/call05.f90 | 19 +++++++++++ 7 files changed, 112 insertions(+), 6 deletions(-) create mode 100644 flang/test/Evaluate/rewrite06.f90 create mode 100644 flang/test/Lower/Intrinsics/storage_size-2.f90 diff --git a/flang/include/flang/Evaluate/call.h b/flang/include/flang/Evaluate/call.h index f2c231647390bd..d8241c08e3b25e 100644 --- a/flang/include/flang/Evaluate/call.h +++ b/flang/include/flang/Evaluate/call.h @@ -268,7 +268,17 @@ template class FunctionRef : public ProcedureRef { FunctionRef(ProcedureDesignator &&p, ActualArguments &&a) : ProcedureRef{std::move(p), std::move(a)} {} - std::optional GetType() const { return proc_.GetType(); } + std::optional GetType() const { + if (auto type{proc_.GetType()}) { + // TODO: Non constant explicit length parameters of PDTs result should + // likely be dropped too. This is not as easy as for characters since some + // long lived DerivedTypeSpec pointer would need to be created here. It is + // not clear if this is causing any issue so far since the storage size of + // PDTs is independent of length parameters. + return type->DropNonConstantCharacterLength(); + } + return std::nullopt; + } }; } // namespace Fortran::evaluate #endif // FORTRAN_EVALUATE_CALL_H_ diff --git a/flang/include/flang/Evaluate/type.h b/flang/include/flang/Evaluate/type.h index eb4050970c1381..13060e42e47adb 100644 --- a/flang/include/flang/Evaluate/type.h +++ b/flang/include/flang/Evaluate/type.h @@ -231,6 +231,12 @@ class DynamicType { } } + // Get a copy of this dynamic type where charLengthParamValue_ is reset if it + // is not a constant expression. This avoids propagating symbol references in + // scopes where they do not belong. Returns the type unmodified if it is not + // a character or if the length is not explicit. + DynamicType DropNonConstantCharacterLength() const; + private: // Special kind codes are used to distinguish the following Fortran types. enum SpecialKind { diff --git a/flang/lib/Evaluate/type.cpp b/flang/lib/Evaluate/type.cpp index 1497c037d9cc6e..e5d9851e2496ae 100644 --- a/flang/lib/Evaluate/type.cpp +++ b/flang/lib/Evaluate/type.cpp @@ -836,4 +836,15 @@ bool IsCUDAIntrinsicType(const DynamicType &type) { } } +DynamicType DynamicType::DropNonConstantCharacterLength() const { + if (charLengthParamValue_ && charLengthParamValue_->isExplicit()) { + if (std::optional len{knownLength()}) { + return DynamicType(kind_, *len); + } else { + return DynamicType(category_, kind_); + } + } + return *this; +} + } // namespace Fortran::evaluate diff --git a/flang/lib/Optimizer/Builder/IntrinsicCall.cpp b/flang/lib/Optimizer/Builder/IntrinsicCall.cpp index 1ae8f08dc116eb..0a023bc6b21ea0 100644 --- a/flang/lib/Optimizer/Builder/IntrinsicCall.cpp +++ b/flang/lib/Optimizer/Builder/IntrinsicCall.cpp @@ -5284,11 +5284,8 @@ IntrinsicLibrary::genStorageSize(mlir::Type resultType, builder.getKindMap().getIntegerBitsize(fir::toInt(constOp))); } - if (args[0].getBoxOf()) { - box = builder.createBox(loc, args[0], /*isPolymorphic=*/true); - } else if (box.getType().isa()) { - box = builder.create(loc, box); - } + box = builder.createBox(loc, args[0], + /*isPolymorphic=*/args[0].isPolymorphic()); mlir::Value eleSize = builder.create(loc, kindTy, box); mlir::Value c8 = builder.createIntegerConstant(loc, kindTy, 8); return builder.create(loc, eleSize, c8); diff --git a/flang/test/Evaluate/rewrite06.f90 b/flang/test/Evaluate/rewrite06.f90 new file mode 100644 index 00000000000000..03eb463fe9bd5d --- /dev/null +++ b/flang/test/Evaluate/rewrite06.f90 @@ -0,0 +1,33 @@ +! RUN: %flang_fc1 -fdebug-unparse %s 2>&1 | FileCheck %s +subroutine test_storage_size(n) + interface + function return_char(l) + integer :: l + character(l) :: return_char + end function + end interface + integer n + !CHECK: PRINT *, storage_size(return_char(n)) + print*, storage_size(return_char(n)) + !CHECK: PRINT *, sizeof(return_char(n)) + print*, sizeof(return_char(n)) +end subroutine + +module pdts + type t(l) + integer, len :: l + character(l) :: c + end type +contains + function return_pdt(n) + type(t(n)) :: return_pdt + end function + subroutine test(k) + ! NOTE: flang design for length parametrized derived type + ! is to use allocatables for the automatic components. Hence, + ! their size is independent from the length parameters and is + ! a compile time constant. + !CHECK: PRINT *, 192_4 + print *, storage_size(return_pdt(k)) + end subroutine +end module diff --git a/flang/test/Lower/Intrinsics/storage_size-2.f90 b/flang/test/Lower/Intrinsics/storage_size-2.f90 new file mode 100644 index 00000000000000..e784063c76c350 --- /dev/null +++ b/flang/test/Lower/Intrinsics/storage_size-2.f90 @@ -0,0 +1,30 @@ +! Test storage_size with characters +! RUN: bbc -emit-hlfir %s -o - | FileCheck %s + +! check-label: func.func @_QPtest_storage_size +subroutine test_storage_size(n) + interface + function return_char(l) + integer :: l + character(l) :: return_char + end function + end interface + integer n + print*, storage_size(return_char(n)) +! CHECK: %[[val_16:.*]] = fir.call @_QPreturn_char(%[[res_addr:[^,]*]], %[[res_len:[^,]*]], {{.*}}) +! CHECK: %[[res:.*]]:2 = hlfir.declare %[[res_addr]] typeparams %[[res_len]] +! CHECK: %[[val_18:.*]] = fir.embox %[[res]]#1 typeparams %[[res_len]] : (!fir.ref>, index) -> !fir.box> +! CHECK: %[[val_19:.*]] = fir.box_elesize %[[val_18]] : (!fir.box>) -> i32 +! CHECK: %[[val_20:.*]] = arith.constant 8 : i32 +! CHECK: %[[val_21:.*]] = arith.muli %[[val_19]], %[[val_20]] : i32 +! CHECK: fir.call @_FortranAioOutputInteger32(%{{.*}}, %[[val_21]]) +end subroutine + +function return_char(l) + integer :: l + character(l) :: return_char +end function + + call test_storage_size(42) + print *, 42*8 +end diff --git a/flang/test/Semantics/call05.f90 b/flang/test/Semantics/call05.f90 index 269a0a3034a9f2..66d0a375fa56de 100644 --- a/flang/test/Semantics/call05.f90 +++ b/flang/test/Semantics/call05.f90 @@ -155,6 +155,15 @@ subroutine smb(b) integer, allocatable, intent(in) :: b(:) end + function return_deferred_length_ptr() + character(len=:), pointer :: return_deferred_length_ptr + end function + + function return_explicit_length_ptr(n) + integer :: n + character(len=n), pointer :: return_explicit_length_ptr + end function + subroutine test() !ERROR: Dummy and actual arguments must defer the same type parameters when POINTER or ALLOCATABLE @@ -167,6 +176,16 @@ subroutine test() call smp2(p1) ! ok + call smp(return_deferred_length_ptr()) ! ok + + !ERROR: Dummy and actual arguments must defer the same type parameters when POINTER or ALLOCATABLE + call smp2(return_deferred_length_ptr()) + + !ERROR: Dummy and actual arguments must defer the same type parameters when POINTER or ALLOCATABLE + call smp(return_explicit_length_ptr(10)) + + call smp2(return_explicit_length_ptr(10)) ! ok + !ERROR: ALLOCATABLE dummy argument 'a=' must be associated with an ALLOCATABLE actual argument call sma(t2(:))