[flang] Fix issues with STORAGE_SIZE and characters

[jeanPerier]

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

[llvmbot]

@llvm/pr-subscribers-flang-semantics

@llvm/pr-subscribers-flang-fir-hlfir

Changes

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

---

Full diff: https://github.com/llvm/llvm-project/pull/67561.diff

7 Files Affected:

• (modified) flang/include/flang/Evaluate/call.h (+6-1)
• (modified) flang/include/flang/Evaluate/type.h (+5)
• (modified) flang/lib/Evaluate/type.cpp (+11)
• (modified) flang/lib/Optimizer/Builder/IntrinsicCall.cpp (+2-5)
• (added) flang/test/Evaluate/rewrite06.f90 (+14)
• (added) flang/test/Lower/Intrinsics/storage_size-2.f90 (+30)
• (modified) flang/test/Semantics/call05.f90 (+19)

diff --git a/flang/include/flang/Evaluate/call.h b/flang/include/flang/Evaluate/call.h
index f2c231647390bde..09673f00d7bddf4 100644
--- a/flang/include/flang/Evaluate/call.h
+++ b/flang/include/flang/Evaluate/call.h
@@ -268,7 +268,12 @@ 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()) {
+      return type->DropNonConstantParameters();
+    }
+    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 eb4050970c1381a..6baf9cf0259e33a 100644
--- a/flang/include/flang/Evaluate/type.h
+++ b/flang/include/flang/Evaluate/type.h
@@ -231,6 +231,11 @@ 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.
+  DynamicType DropNonConstantParameters() 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 1497c037d9cc6e3..cff265bcd1ff379 100644
--- a/flang/lib/Evaluate/type.cpp
+++ b/flang/lib/Evaluate/type.cpp
@@ -836,4 +836,15 @@ bool IsCUDAIntrinsicType(const DynamicType &type) {
   }
 }
 
+DynamicType DynamicType::DropNonConstantParameters() 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
diff --git a/flang/lib/Optimizer/Builder/IntrinsicCall.cpp b/flang/lib/Optimizer/Builder/IntrinsicCall.cpp
index 1ae8f08dc116eb4..0a023bc6b21ea03 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<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);
diff --git a/flang/test/Evaluate/rewrite06.f90 b/flang/test/Evaluate/rewrite06.f90
new file mode 100644
index 000000000000000..8f6aa200b4140dc
--- /dev/null
+++ b/flang/test/Evaluate/rewrite06.f90
@@ -0,0 +1,14 @@
+! 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
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 000000000000000..e784063c76c350c
--- /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<!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
diff --git a/flang/test/Semantics/call05.f90 b/flang/test/Semantics/call05.f90
index 269a0a3034a9f2b..66d0a375fa56de2 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(:))
 

[klausler]

Please handle PDT LEN parameters as well, or add a TODO comment about them.

[jeanPerier]

Thanks for mentioning them, this is not as easy as for characters since this would require allocating new DerivedTypeSpec somewhere where they can survive long enough.
I cannot expose any bugs right now with this since the storage size of PDTs is a compile time constant with flang design, so I renamed this helper to be character specific and added a TODO note in FunctionRef::GetType and a storage_type rewrite test with PDTs.