[flang] Ensure pointer components are always established

[jeanPerier]

Summary

Follow up of https://reviews.llvm.org/D149979 for lowering.

In Fortran, it is possible to assign a pointer to another pointer
with an undefined association status.
When using the runtime do to none trivial pointer association, if the
descriptor are garbage, the runtime cannot safely detect that it has
a garbage descriptor, and it cannot safely know the descriptor size
leading to undefined behavior.
Another reason to initialize descriptor of pointers is to record any
non deferred length parameter value.
Hence, although this is not required by Fortran, f18 always initialize
pointers to NULL().
This was already done in lowering for whole pointer object, but not for
pointer components.

This patch uses the related semantics patch that updated
derivedTypeSpe::HasDefaultInitialization to ensure pointer components
of local and global object are always initialized.

It adds tests to ensure that allocation of such derived type uses the
runtime to ensure the storage is initialized, and that structure
constructors are setting the descriptor component to NULL() if no
initial target is given.

[klausler]

Thanks for closing the loop on this.

[vzakhari]

Thank you!

flang/lib/Lower/ConvertVariable.cpp

 }
 
 /// Does this variable have a default initialization?
 static bool hasDefaultInitialization(const Fortran::semantics::Symbol &sym) {
   if (sym.has<Fortran::semantics::ObjectEntityDetails>() && sym.size())
     if (!Fortran::semantics::IsAllocatableOrPointer(sym))
       if (const Fortran::semantics::DeclTypeSpec *declTypeSpec = sym.GetType())
         if (const Fortran::semantics::DerivedTypeSpec *derivedTypeSpec =
-                declTypeSpec->AsDerived())
-          return derivedTypeSpec->HasDefaultInitialization();
+                declTypeSpec->AsDerived()) {
+          // Pointer assignments in the runtime may hit undefined behaviors if
+          // the RHS contains garbage. Pointer objects are always established by
+          // lowering to NULL() (in Fortran::lower::createMutableBox). However,
+          // pointer components need special care here so that local and global
+          // derived type containing pointers are always initialized.
+          // Intent(out), however, do not need to be initialized since the
+          // related descriptor storage comes from a local or global that has
+          // been initialized (it may not be NULL() anymore, but the rank, type,
+          // and non deferred length parameters are still correct in a
+          // conformant program, and that is what matters).
+          const bool ignorePointer = Fortran::semantics::IsIntentOut(sym);
+          return derivedTypeSpec->HasDefaultInitialization(
+              /*ignoreAllocatable=*/false, ignorePointer);
+        }
   return false;
 }
 
 // Does this variable have a finalization?
 static bool hasFinalization(const Fortran::semantics::Symbol &sym) {
   if (sym.has<Fortran::semantics::ObjectEntityDetails>() && sym.size())
     if (const Fortran::semantics::DeclTypeSpec *declTypeSpec = sym.GetType())
       if (const Fortran::semantics::DerivedTypeSpec *derivedTypeSpec =

flang/test/Lower/call-copy-in-out.f90

 subroutine whole_component_contiguous_char_pointer()
   ! Test no copy is made for whole contiguous character pointer components.
   type t
     character(:), pointer, contiguous :: i(:)
   end type
   ! CHECK: %[[a:.*]] = fir.alloca !fir.type<_QFwhole_component_contiguous_char_pointerTt{i:!fir.box<!fir.ptr<!fir.array<?x!fir.char<1,?>>>>}>
   type(t) :: a
   ! CHECK: %[[field:.*]] = fir.field_index i, !fir.type<_QFwhole_component_contiguous_char_pointerTt{i:!fir.box<!fir.ptr<!fir.array<?x!fir.char<1,?>>>>}>
-  ! CHECK: %[[coor:.*]] = fir.coordinate_of %0, %1 : (!fir.ref<!fir.type<_QFwhole_component_contiguous_char_pointerTt{i:!fir.box<!fir.ptr<!fir.array<?x!fir.char<1,?>>>>}>>, !fir.field) -> !fir.ref<!fir.box<!fir.ptr<!fir.array<?x!fir.char<1,?>>>>>
+  ! CHECK: %[[coor:.*]] = fir.coordinate_of %[[a]], %[[field]] : (!fir.ref<!fir.type<_QFwhole_component_contiguous_char_pointerTt{i:!fir.box<!fir.ptr<!fir.array<?x!fir.char<1,?>>>>}>>, !fir.field) -> !fir.ref<!fir.box<!fir.ptr<!fir.array<?x!fir.char<1,?>>>>>
   ! CHECK: %[[box_load:.*]] = fir.load %[[coor]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?x!fir.char<1,?>>>>>
   ! CHECK: %[[addr:.*]] = fir.box_addr %[[box_load]] : (!fir.box<!fir.ptr<!fir.array<?x!fir.char<1,?>>>>) -> !fir.ptr<!fir.array<?x!fir.char<1,?>>>
   ! CHECK: %[[len:.*]] = fir.box_elesize %[[box_load]] : (!fir.box<!fir.ptr<!fir.array<?x!fir.char<1,?>>>>) -> index
   ! CHECK: %[[cast:.*]] = fir.convert %[[addr]] : (!fir.ptr<!fir.array<?x!fir.char<1,?>>>) -> !fir.ref<!fir.char<1,?>>
   ! CHECK: %[[embox:.*]] = fir.emboxchar %[[cast]], %[[len]] : (!fir.ref<!fir.char<1,?>>, index) -> !fir.boxchar<1>
   ! CHECK: fir.call @_QPbar_char_3(%[[embox]]) {{.*}}: (!fir.boxchar<1>) -> ()
   call bar_char_3(a%i)
 end subroutine

flang/test/Lower/pointer-default-init.f90

+! Test that pointer and pointer components are always initialized to a
+! clean NULL() status. This is required by f18 runtime to do pointer
+! association with a RHS with an undefined association status from a
+! Fortran point of view.
+! RUN: bbc -emit-fir -I nw %s -o - | FileCheck %s
+
+module test
+  type t
+    integer :: i
+    real, pointer :: x(:)
+  end type
+
+  real, pointer :: test_module_pointer(:)
+! CHECK-LABEL:   fir.global @_QMtestEtest_module_pointer : !fir.box<!fir.ptr<!fir.array<?xf32>>> {
+! CHECK:  %[[VAL_0:.*]] = fir.zero_bits !fir.ptr<!fir.array<?xf32>>
+! CHECK:  %[[VAL_1:.*]] = arith.constant 0 : index
+! CHECK:  %[[VAL_2:.*]] = fir.shape %[[VAL_1]] : (index) -> !fir.shape<1>
+! CHECK:  %[[VAL_3:.*]] = fir.embox %[[VAL_0]](%[[VAL_2]]) : (!fir.ptr<!fir.array<?xf32>>, !fir.shape<1>) -> !fir.box<!fir.ptr<!fir.array<?xf32>>>
+! CHECK:  fir.has_value %[[VAL_3]] : !fir.box<!fir.ptr<!fir.array<?xf32>>>
+
+  type(t) :: test_module_var
+! CHECK-LABEL:   fir.global @_QMtestEtest_module_var : !fir.type<_QMtestTt{i:i32,x:!fir.box<!fir.ptr<!fir.array<?xf32>>>}> {
+! CHECK:  %[[VAL_0:.*]] = fir.undefined !fir.type<_QMtestTt{i:i32,x:!fir.box<!fir.ptr<!fir.array<?xf32>>>}>
+! CHECK:  %[[VAL_1:.*]] = fir.undefined i32
+! CHECK:  %[[VAL_2:.*]] = fir.field_index i
+! CHECK:  %[[VAL_3:.*]] = fir.insert_value %[[VAL_0]], %[[VAL_1]]
+! CHECK:  %[[VAL_4:.*]] = fir.zero_bits !fir.ptr<!fir.array<?xf32>>
+! CHECK:  %[[VAL_5:.*]] = arith.constant 0 : index
+! CHECK:  %[[VAL_6:.*]] = fir.shape %[[VAL_5]] : (index) -> !fir.shape<1>
+! CHECK:  %[[VAL_7:.*]] = fir.embox %[[VAL_4]](%[[VAL_6]]) : (!fir.ptr<!fir.array<?xf32>>, !fir.shape<1>) -> !fir.box<!fir.ptr<!fir.array<?xf32>>>
+! CHECK:  %[[VAL_8:.*]] = fir.field_index x
+! CHECK:  %[[VAL_9:.*]] = fir.insert_value %[[VAL_3]], %[[VAL_7]]
+! CHECK:  fir.has_value %[[VAL_9]]
+end module
+
+subroutine test_local()
+  use test, only : t
+  type(t) :: x
+end subroutine
+! CHECK-LABEL:   func.func @_QPtest_local() {
+! CHECK:  fir.call @_FortranAInitialize(
+
+subroutine test_saved()
+  use test, only : t
+  type(t), save :: x
+end subroutine
+! See check for fir.global internal @_QFtest_savedEx below.
+
+subroutine test_alloc(x)
+  use test, only : t
+  type(t), allocatable :: x
+  allocate(x)
+end subroutine
+! CHECK-LABEL:   func.func @_QPtest_alloc(
+! CHECK:  fir.call @_FortranAAllocatableAllocate
+
+subroutine test_intentout(x)
+  use test, only : t
+  type(t), intent(out):: x
+end subroutine
+! CHECK-LABEL:   func.func @_QPtest_intentout(
+! CHECK-NOT:           fir.call @_FortranAInitialize(
+! CHECK:  return
+
+subroutine test_struct_ctor_cst(x)
+  use test, only : t
+  type(t):: x
+  x = t(42)
+end subroutine
+! CHECK-LABEL:   func.func @_QPtest_struct_ctor_cst(
+! CHECK:  fir.call @_FortranAInitialize(
+
+subroutine test_struct_ctor_dyn(x, i)
+  use test, only : t
+  type(t):: x
+  integer :: i
+  x = t(i)
+end subroutine
+! CHECK-LABEL:   func.func @_QPtest_struct_ctor_dyn(
+! CHECK:  fir.call @_FortranAInitialize(
+
+subroutine test_local_pointer()
+  real, pointer :: x(:)
+end subroutine
+! CHECK-LABEL:   func.func @_QPtest_local_pointer() {
+! CHECK:  %[[VAL_0:.*]] = fir.alloca !fir.box<!fir.ptr<!fir.array<?xf32>>> {bindc_name = "x", uniq_name = "_QFtest_local_pointerEx"}
+! CHECK:  %[[VAL_1:.*]] = fir.zero_bits !fir.ptr<!fir.array<?xf32>>
+! CHECK:  %[[VAL_2:.*]] = arith.constant 0 : index
+! CHECK:  %[[VAL_3:.*]] = fir.shape %[[VAL_2]] : (index) -> !fir.shape<1>
+! CHECK:  %[[VAL_4:.*]] = fir.embox %[[VAL_1]](%[[VAL_3]]) : (!fir.ptr<!fir.array<?xf32>>, !fir.shape<1>) -> !fir.box<!fir.ptr<!fir.array<?xf32>>>
+! CHECK:  fir.store %[[VAL_4]] to %[[VAL_0]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>
+
+subroutine test_saved_pointer()
+  real, pointer, save :: x(:)
+end subroutine
+! See check for fir.global internal @_QFtest_saved_pointerEx below.
+
+! CHECK-LABEL:   fir.global internal @_QFtest_savedEx : !fir.type<_QMtestTt{i:i32,x:!fir.box<!fir.ptr<!fir.array<?xf32>>>}> {
+! CHECK:  %[[VAL_0:.*]] = fir.undefined !fir.type<_QMtestTt{i:i32,x:!fir.box<!fir.ptr<!fir.array<?xf32>>>}>
+! CHECK:  %[[VAL_1:.*]] = fir.undefined i32
+! CHECK:  %[[VAL_2:.*]] = fir.field_index i
+! CHECK:  %[[VAL_3:.*]] = fir.insert_value %[[VAL_0]], %[[VAL_1]]
+! CHECK:  %[[VAL_4:.*]] = fir.zero_bits !fir.ptr<!fir.array<?xf32>>
+! CHECK:  %[[VAL_5:.*]] = arith.constant 0 : index
+! CHECK:  %[[VAL_6:.*]] = fir.shape %[[VAL_5]] : (index) -> !fir.shape<1>
+! CHECK:  %[[VAL_7:.*]] = fir.embox %[[VAL_4]](%[[VAL_6]]) : (!fir.ptr<!fir.array<?xf32>>, !fir.shape<1>) -> !fir.box<!fir.ptr<!fir.array<?xf32>>>
+! CHECK:  %[[VAL_8:.*]] = fir.field_index x
+! CHECK:  %[[VAL_9:.*]] = fir.insert_value %[[VAL_3]], %[[VAL_7]]
+! CHECK:  fir.has_value %[[VAL_9]]
+
+! CHECK-LABEL:   fir.global internal @_QFtest_saved_pointerEx : !fir.box<!fir.ptr<!fir.array<?xf32>>> {
+! CHECK:  %[[VAL_0:.*]] = fir.zero_bits !fir.ptr<!fir.array<?xf32>>
+! CHECK:  %[[VAL_1:.*]] = arith.constant 0 : index
+! CHECK:  %[[VAL_2:.*]] = fir.shape %[[VAL_1]] : (index) -> !fir.shape<1>
+! CHECK:  %[[VAL_3:.*]] = fir.embox %[[VAL_0]](%[[VAL_2]]) : (!fir.ptr<!fir.array<?xf32>>, !fir.shape<1>) -> !fir.box<!fir.ptr<!fir.array<?xf32>>>
+! CHECK:  fir.has_value %[[VAL_3]] : !fir.box<!fir.ptr<!fir.array<?xf32>>>