[flang] Preserve bound info for pointer assignments through derived types

[jpenix-quic]

Summary

Doing a pointer assignment to another pointer which is a derived type component
could result in the bound information being lost, potentially leading to
incorrect array accesses. Fix this by trying to retain the bound info during
the assignment.

Fixes #57441

[jpenix-quic]

flang/lib/Lower/ConvertExpr.cpp

5649

I'm not sure what to do about the explicitParams field in the BoxValue constructor below. For the lbounds, grabbing the bounds from the original array and dropping them if we are taking a slice seems correct to me, but this doesn't seem right for the explicitParams/lens. Should I be trying to add the lengths of the slice or something else? I guess always dropping the info would be "safe" in the sense that that was the previous behavior, but I'm not sure what is correct/expected.

flang/test/Lower/pointer-assignments.f90

84

In the test here, there is a redundant shift to get the lower bounds that I think is coming from the code here (https://github.com/llvm/llvm-project/blob/bbcffb08f0fdc0be8c8cba48410f9cb556ea661d/flang/lib/Optimizer/Builder/MutableBox.cpp#L528-L533). I had some success with eliminating the shift for this test in particular by trying to look through arr via getAddr() and checking the operands for a shift/shape_shift and reusing that. However, this seemed to be a fairly brittle check (though I might have just been doing things in an odd way) and only seemed to be safe if the lbounds passed into the function was empty (indicating no bounds remapping, if I understand correctly). As such, I ended up dropping this. Should I be worried about the redundant shift in this case or is there a different/better way I could approach this?

[jeanPerier]

It looks like you are doing the right thing here, thanks !

flang/lib/Lower/ConvertExpr.cpp

5649

That seems a correct thing to do. Outside of when creating a MutableBox, propagating the non deferred length parameters does not matter from a semantic/correctness point of view (because the lengths are in the box anyway), but it will matter for performance at some point. For instance: character(n), contiguous :: x(:), y(:) The non deferred parameter n will allow optimizing an assignment x=y because it allows deducing that x and y are the same length and that given no padding is needed, the whole array assignment can be done as a block memcopy.

So it is better to keep track of it as you are doing here.

flang/test/Lower/pointer-assignments.f90

84

It does not matter. fir::ShiftOp has no side effect, so the common subexpression elimination pass will get rid of the redundant fir.shift (you can test with fir-opt-cse). While it is frustrating to produce and see redundant IR in the tests, if it is not trivial to avoid it, it is best to rely on the CSE pass to do it.

[jpenix-quic]

@jeanPerier Thank you for going over my questions--the help and explanations are greatly appreciated!

If I am understanding correctly, I think I can leave things as they are, so I will fix up the title/description/one source comment and then I think this should be ready for review!

flang/lib/Lower/ConvertExpr.cpp

5649

Ok, makes sense and thank you for the explanation! If I am understanding correctly then, I will leave things as is!

flang/test/Lower/pointer-assignments.f90

84

Got it, thanks! I will leave it as is then.

[jpenix-quic]

Remove old source note I left in, remove WIP and note about questions from the title and summary.

[jeanPerier]

Looks good to me, thanks for finding and fixing the issue !

[kiranchandramohan]

Confirmed that cam4_r passes with this change. Thanks once again @jpenix-quic.

flang/lib/Lower/ConvertExpr.cpp

if (isBoxValue()) {
             fir::factory::CharacterExprHelper::getCharType(reduceTy);
         auto seqTy = reduceTy.cast<fir::SequenceType>();
         // TODO: Use a constant for fir.char LEN if we can compute it.
         boxTy = fir::BoxType::get(
             fir::SequenceType::get(fir::CharacterType::getUnknownLen(
                                        builder.getContext(), charTy.getFKind()),
                                    seqTy.getDimension()));
       }
+      llvm::SmallVector<mlir::Value> lbounds;
+      llvm::SmallVector<mlir::Value> nonDeferredLenParams;
+      if (!slice) {
+        lbounds =
+            fir::factory::getNonDefaultLowerBounds(builder, loc, extMemref);
+        nonDeferredLenParams = fir::factory::getNonDeferredLenParams(extMemref);
+      }
       mlir::Value embox =
           memref.getType().isa<fir::BaseBoxType>()
               ? builder.create<fir::ReboxOp>(loc, boxTy, memref, shape, slice)
                     .getResult()
               : builder
                     .create<fir::EmboxOp>(loc, boxTy, memref, shape, slice,
                                           fir::getTypeParams(extMemref))
                     .getResult();
-      return [=](IterSpace) -> ExtValue { return fir::BoxValue(embox); };
+      return [=](IterSpace) -> ExtValue {
+        return fir::BoxValue(embox, lbounds, nonDeferredLenParams);
+      };
     }
     auto eleTy = arrTy.cast<fir::SequenceType>().getEleTy();
     if (isReferentiallyOpaque()) {
       // Semantics are an opaque reference to an array.
       // This case forwards a continuation that will generate the address
       // arithmetic to the array element. This does not have copy-in/copy-out
       // semantics. No attempt to copy the array value will be made during the
       // interpretation of the Fortran statement.

flang/test/Lower/parent-component.f90

contains
   ! CHECK: %[[LOAD_LB0:.*]] = fir.load %[[LB0]] : !fir.ref<index>
   ! CHECK: %[[LOAD_EXT0:.*]] = fir.load %[[EXT0]] : !fir.ref<index>
   ! CHECK: %[[MEM:.*]] = fir.load %[[ALLOC]] : !fir.ref<!fir.heap<!fir.array<?x!fir.type<_QFTc{a:i32,b:i32}>>>>
   ! CHECK: %[[SHAPE_SHIFT:.*]] = fir.shape_shift %[[LOAD_LB0]], %[[LOAD_EXT0]] : (index, index) -> !fir.shapeshift<1>
   ! CHECK: %[[FIELD:.*]] = fir.field_index a, !fir.type<_QFTc{a:i32,b:i32}>
   ! CHECK: %[[C0:.*]] = arith.constant 0 : index
   ! CHECK: %[[BOX_DIMS:.*]]:3 = fir.box_dims %{{.*}}, %[[C0]] : (!fir.box<!fir.array<?x!fir.type<_QFTc{a:i32,b:i32}>>>, index) -> (index, index, index)
   ! CHECK: %[[C1:.*]] = arith.constant 1 : index
-  ! CHECK: %[[SLICE:.*]] = fir.slice %[[C1]], %[[BOX_DIMS]]#1, %[[C1]] path %[[FIELD]] : (index, index, index, !fir.field) -> !fir.slice<1>
+  ! CHECK: %[[BOUND_OFFSET:.*]] = arith.subi %[[LOAD_LB0]], %[[C1]] : index
+  ! CHECK: %[[UB:.*]] = arith.addi %[[BOX_DIMS]]#1, %[[BOUND_OFFSET]] : index
+  ! CHECK: %[[SLICE:.*]] = fir.slice %[[LOAD_LB0]], %[[UB]], %[[C1]] path %[[FIELD]] : (index, index, index, !fir.field) -> !fir.slice<1>
   ! CHECK: %[[BOX:.*]] = fir.embox %[[MEM]](%[[SHAPE_SHIFT]]) [%[[SLICE]]] : (!fir.heap<!fir.array<?x!fir.type<_QFTc{a:i32,b:i32}>>>, !fir.shapeshift<1>, !fir.slice<1>) -> !fir.box<!fir.array<?x!fir.type<_QFTp{a:i32}>>>
   ! CHECK: %[[BOX_NONE:.*]] = fir.convert %[[BOX]] : (!fir.box<!fir.array<?x!fir.type<_QFTp{a:i32}>>>) -> !fir.box<none> 
   ! CHECK: %[[IS_CONTIGOUS:.*]] = fir.call @_FortranAIsContiguous(%[[BOX_NONE]]) {{.*}}: (!fir.box<none>) -> i1
   ! CHECK: %[[TEMP:.*]] = fir.if %[[IS_CONTIGOUS]] -> (!fir.heap<!fir.array<?x!fir.type<_QFTp{a:i32}>>>) {
   ! CHECK: } else {
   ! CHECK: %{{.*}} = fir.do_loop %{{.*}} = %{{.*}} to %{{.*}} step %{{.*}} unordered iter_args(%{{.*}} = %{{.*}}) -> (!fir.array<?x!fir.type<_QFTp{a:i32}>>)
   ! CHECK: %{{.*}} = fir.field_index a, !fir.type<_QFTp{a:i32}>
   ! CHECK-NOT: %{{.*}} = fir.field_index b, !fir.type<_QFTp{a:i32}>
   ! CHECK: %[[TEMP_CAST:.*]] = fir.convert %[[TEMP]] : (!fir.heap<!fir.array<?x!fir.type<_QFTp{a:i32}>>>) -> !fir.ref<!fir.array<2x!fir.type<_QFTp{a:i32}>>>
   ! CHECK: fir.call @_QFPprint_p(%[[TEMP_CAST]]) {{.*}}: (!fir.ref<!fir.array<2x!fir.type<_QFTp{a:i32}>>>) -> ()
 
   ! CHECK-LABEL: %{{.*}} = fir.call @_FortranAioBeginExternalListOutput(%{{.*}}, %{{.*}}, %{{.*}}) {{.*}}: (i32, !fir.ref<i8>, i32) -> !fir.ref<i8>
   ! CHECK: %[[LOAD_LB0:.*]] = fir.load %[[LB0]] : !fir.ref<index>
   ! CHECK: %[[LOAD_EXT0:.*]] = fir.load %[[EXT0]] : !fir.ref<index>
   ! CHECK: %[[LOAD_ALLOC:.*]] = fir.load %[[ALLOC]] : !fir.ref<!fir.heap<!fir.array<?x!fir.type<_QFTc{a:i32,b:i32}>>>>
   ! CHECK: %[[SHAPE_SHIFT:.*]] = fir.shape_shift %[[LOAD_LB0]], %[[LOAD_EXT0]] : (index, index) -> !fir.shapeshift<1>
   ! CHECK: %[[FIELD:.*]] = fir.field_index a, !fir.type<_QFTc{a:i32,b:i32}>
   ! CHECK: %[[C0:.*]] = arith.constant 0 : index
   ! CHECK: %[[BOX_DIMS:.*]]:3 = fir.box_dims %{{.*}}, %[[C0]] : (!fir.box<!fir.array<?x!fir.type<_QFTc{a:i32,b:i32}>>>, index) -> (index, index, index)
   ! CHECK: %[[C1:.*]] = arith.constant 1 : index
-  ! CHECK: %[[SLICE:.*]] = fir.slice %[[C1]], %[[BOX_DIMS]]#1, %[[C1]] path %[[FIELD]] : (index, index, index, !fir.field) -> !fir.slice<1>
+  ! CHECK: %[[BOUND_OFFSET:.*]] = arith.subi %[[LOAD_LB0]], %[[C1]] : index
+  ! CHECK: %[[UB:.*]] = arith.addi %[[BOX_DIMS]]#1, %[[BOUND_OFFSET]] : index
+  ! CHECK: %[[SLICE:.*]] = fir.slice %[[LOAD_LB0]], %[[UB]], %[[C1]] path %[[FIELD]] : (index, index, index, !fir.field) -> !fir.slice<1>
   ! CHECK: %[[BOX:.*]] = fir.embox %[[LOAD_ALLOC]](%[[SHAPE_SHIFT]]) [%[[SLICE]]] : (!fir.heap<!fir.array<?x!fir.type<_QFTc{a:i32,b:i32}>>>, !fir.shapeshift<1>, !fir.slice<1>) -> !fir.box<!fir.array<?x!fir.type<_QFTp{a:i32}>>>
   ! CHECK: %[[BOX_NONE:.*]] = fir.convert %[[BOX]] : (!fir.box<!fir.array<?x!fir.type<_QFTp{a:i32}>>>) -> !fir.box<none>
   ! CHECK: %{{.*}} = fir.call @_FortranAioOutputDescriptor(%{{.*}}, %[[BOX_NONE]]) {{.*}}: (!fir.ref<i8>, !fir.box<none>) -> i1
 
   subroutine init_scalar()
     type(c) :: s = c(11, 21)
     call print_scalar(s%p)
     print*,s%p

flang/test/Lower/pointer-assignments.f90

subroutine test_array_with_lbs(p, x)
   real, target :: x(51:150)
   real, pointer :: p(:)
   ! CHECK: %[[shape:.*]] = fir.shape_shift %c51{{.*}}, %c100{{.*}}
   ! CHECK: %[[box:.*]] = fir.embox %{{.*}}(%[[shape]]) : (!fir.ref<!fir.array<100xf32>>, !fir.shapeshift<1>) -> !fir.box<!fir.ptr<!fir.array<?xf32>>>
   ! CHECK: fir.store %[[box]] to %[[p]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>
   p => x
 end subroutine
 
+! Test that the lhs takes the bounds from rhs.
+! CHECK-LABEL: func @_QPtest_pointer_component(
+! CHECK-SAME: %[[temp:.*]]: !fir.ref<!fir.type<_QFtest_pointer_componentTmytype{ptr:!fir.box<!fir.ptr<!fir.array<?xf32>>>}>> {fir.bindc_name = "temp"}, %[[temp_ptr:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>> {fir.bindc_name = "temp_ptr"}) {
+subroutine test_pointer_component(temp, temp_ptr)
+  type mytype
+    real, pointer :: ptr(:)
+  end type mytype
+  type(mytype) :: temp
+  real, pointer :: temp_ptr(:)
+  ! CHECK: %[[ptr_addr:.*]] = fir.coordinate_of %[[temp]], %{{.*}} : (!fir.ref<!fir.type<_QFtest_pointer_componentTmytype{ptr:!fir.box<!fir.ptr<!fir.array<?xf32>>>}>>, !fir.field) -> !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>
+  ! CHECK: %[[ptr:.*]] = fir.load %[[ptr_addr]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>
+  ! CHECK: %[[dims:.*]]:3 = fir.box_dims %[[ptr]], %{{.*}} : (!fir.box<!fir.ptr<!fir.array<?xf32>>>, index) -> (index, index, index)
+  ! CHECK: %[[shift:.*]] = fir.shift %[[dims]]#0 : (index) -> !fir.shift<1>
+  ! CHECK: %[[arr_box:.*]] = fir.rebox %[[ptr]](%[[shift]]) : (!fir.box<!fir.ptr<!fir.array<?xf32>>>, !fir.shift<1>) -> !fir.box<!fir.array<?xf32>>
+  ! CHECK: %[[shift2:.*]] = fir.shift %[[dims]]#0 : (index) -> !fir.shift<1>
+  ! CHECK: %[[final_box:.*]] = fir.rebox %[[arr_box]](%[[shift2]]) : (!fir.box<!fir.array<?xf32>>, !fir.shift<1>) -> !fir.box<!fir.ptr<!fir.array<?xf32>>>
+  ! CHECK: fir.store %[[final_box]] to %[[temp_ptr]] : !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>
+  temp_ptr => temp%ptr
+end subroutine
+
 ! -----------------------------------------------------------------------------
 !    Test pointer assignments with bound specs to contiguous right-hand side
 ! -----------------------------------------------------------------------------
 
 ! Test 10.2.2.3 point 10: lower bounds requirements:
 ! pointer takes lbounds from bound spec if specified
 ! CHECK-LABEL: func @_QPtest_array_with_new_lbs(
 ! CHECK-SAME: %[[p:.*]]: !fir.ref<!fir.box<!fir.ptr<!fir.array<?xf32>>>>