[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).

Author: jeanPerier

flang/include/flang/Evaluate/call.h

@@ -268,7 +268,17 @@ template <typename A> class FunctionRef : public ProcedureRef {
   FunctionRef(ProcedureDesignator &&p, ActualArguments &&a)
       : ProcedureRef{std::move(p), std::move(a)} {}
 
-  std::optional<DynamicType> GetType() const { return proc_.GetType(); }
+  std::optional<DynamicType> 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_

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 {

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<std::int64_t> len{knownLength()}) {
+      return DynamicType(kind_, *len);
+    } else {
+      return DynamicType(category_, kind_);
+    }
+  }
+  return *this;
+}
+
 } // namespace Fortran::evaluate

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<fir::PolymorphicValue>()) {
-    box = builder.createBox(loc, args[0], /*isPolymorphic=*/true);
-  } else if (box.getType().isa<fir::ReferenceType>()) {
-    box = builder.create<fir::LoadOp>(loc, box);
-  }
+  box = builder.createBox(loc, args[0],
+                          /*isPolymorphic=*/args[0].isPolymorphic());
   mlir::Value eleSize = builder.create<fir::BoxEleSizeOp>(loc, kindTy, box);
   mlir::Value c8 = builder.createIntegerConstant(loc, kindTy, 8);
   return builder.create<mlir::arith::MulIOp>(loc, eleSize, c8);

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

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<!fir.char<1,?>>, index) -> !fir.box<!fir.char<1,?>>
+! CHECK: %[[val_19:.*]] = fir.box_elesize %[[val_18]] : (!fir.box<!fir.char<1,?>>) -> 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

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(:))