[flang] Use PointerAssociateLowerBounds when there is lower bounds

[clementval]

Summary

The current code was not taking provided lower bounds when the pointer
is polymorphic and was just calling PointerAssociate. This patch
updates the behavior and use PointerAssociateLowerBounds with the provided
lower bounds.

[jeanPerier]

I think PointerAssociateLowerBounds must be called instead here. At first, I though, why not using computing ubounds even if not needed and using PointerAssociateRemapping to re-use createBoundArray like you did, but pointer association with bounds remapping is special because it requires the target to be contiguous (except maybe in the first dimension), which the normal pointer association, with potential new lower bounds, does not. The runtime relies on this contiguity to compute the new strides for the pointer in PointerAssociateRemapping. So `PointerAssociateRemapping cannot be used here.
I expect the following would give bad results:

module test
type t
 integer :: i
end type

contains
subroutine assoc(p, z)
 class(t), pointer :: p(:, :)
 class(t), target :: z(:, :)
 p(2:, 2:) => z
end subroutine
end module

 use test
 type(t) :: z(10, 10)
 class(t), pointer :: p(:, :)
 do j = 0, 9
  do i = 1,10
   z(i, j+1)%i = i + j*10
  end do
 end do
 call assoc(p, z(1:10:5, 1:10:5))
 print *, p(2:,2:)%i
end

This should print "1 6 51 56". The last two numbers will probably something else with this patch.

[clementval]

In D143392#4106665, @jeanPerier wrote:

I think PointerAssociateLowerBounds must be called instead here. At first, I though, why not using computing ubounds even if not needed and using PointerAssociateRemapping to re-use createBoundArray like you did, but pointer association with bounds remapping is special because it requires the target to be contiguous (except maybe in the first dimension), which the normal pointer association, with potential new lower bounds, does not. The runtime relies on this contiguity to compute the new strides for the pointer in PointerAssociateRemapping. So `PointerAssociateRemapping cannot be used here.
I expect the following would give bad results:

module test
type t
 integer :: i
end type

contains
subroutine assoc(p, z)
 class(t), pointer :: p(:, :)
 class(t), target :: z(:, :)
 p(2:, 2:) => z
end subroutine
end module

 use test
 type(t) :: z(10, 10)
 class(t), pointer :: p(:, :)
 do j = 0, 9
  do i = 1,10
   z(i, j+1)%i = i + j*10
  end do
 end do
 call assoc(p, z(1:10:5, 1:10:5))
 print *, p(2:,2:)%i
end

This should print "1 6 51 56". The last two numbers will probably something else with this patch.

Somehow I didn't find PointerAssociateLowerBounds when I looked into the runtime :-). The test seems to pass with this but I'll update the patch to make use of the correct runtime function.

[clementval]

Switch to use PointerAssociateLowerBounds

[jeanPerier]

LGTM

[clementval]

clang-format

[clementval]

Rebase

flang/include/flang/Lower/Runtime.h

 void genUnlockStatement(AbstractConverter &, const parser::UnlockStmt &);
 void genPauseStatement(AbstractConverter &, const parser::PauseStmt &);
 
 void genPointerAssociate(fir::FirOpBuilder &, mlir::Location,
                          mlir::Value pointer, mlir::Value target);
 void genPointerAssociateRemapping(fir::FirOpBuilder &, mlir::Location,
                                   mlir::Value pointer, mlir::Value target,
                                   mlir::Value bounds);
+void genPointerAssociateLowerBounds(fir::FirOpBuilder &, mlir::Location,
+                                    mlir::Value pointer, mlir::Value target,
+                                    mlir::Value lbounds);
 } // namespace lower
 } // namespace Fortran
 
 #endif // FORTRAN_LOWER_RUNTIME_H

flang/lib/Lower/Bridge.cpp

 #include "flang/Parser/parse-tree.h"
 #include "flang/Runtime/iostat.h"
 #include "flang/Semantics/runtime-type-info.h"
 #include "flang/Semantics/tools.h"
 #include "mlir/Dialect/ControlFlow/IR/ControlFlowOps.h"
 #include "mlir/IR/PatternMatch.h"
 #include "mlir/Parser/Parser.h"
 #include "mlir/Transforms/RegionUtils.h"
+#include "llvm/ADT/SmallVector.h"
 #include "llvm/ADT/StringSet.h"
 #include "llvm/Support/CommandLine.h"
 #include "llvm/Support/Debug.h"
 #include "llvm/Support/ErrorHandling.h"
 #include "llvm/Support/FileSystem.h"
 #include "llvm/Support/Path.h"
 #include <optional>
 
#endif
   genExprMutableBox(mlir::Location loc,
                     const Fortran::lower::SomeExpr &expr) override final {
     if (lowerToHighLevelFIR())
       return Fortran::lower::convertExprToMutableBox(loc, *this, expr,
                                                      localSymbols);
     return Fortran::lower::createMutableBox(loc, *this, expr, localSymbols);
   }
 
+  // Create the [newRank] array with the lower bounds to be passed to the
+  // runtime as a descriptor.
+  mlir::Value createLboundArray(llvm::ArrayRef<mlir::Value> lbounds,
+                                mlir::Location loc) {
+    mlir::Type indexTy = builder->getIndexType();
+    mlir::Type boundArrayTy = fir::SequenceType::get(
+        {static_cast<int64_t>(lbounds.size())}, builder->getI64Type());
+    mlir::Value boundArray = builder->create<fir::AllocaOp>(loc, boundArrayTy);
+    mlir::Value array = builder->create<fir::UndefOp>(loc, boundArrayTy);
+    for (unsigned i = 0; i < lbounds.size(); ++i) {
+      array = builder->create<fir::InsertValueOp>(
+          loc, boundArrayTy, array, lbounds[i],
+          builder->getArrayAttr({builder->getIntegerAttr(
+              builder->getIndexType(), static_cast<int>(i))}));
+    }
+    builder->create<fir::StoreOp>(loc, array, boundArray);
+    mlir::Type boxTy = fir::BoxType::get(boundArrayTy);
+    mlir::Value ext =
+        builder->createIntegerConstant(loc, indexTy, lbounds.size());
+    llvm::SmallVector<mlir::Value> shapes = {ext};
+    mlir::Value shapeOp = builder->genShape(loc, shapes);
+    return builder->create<fir::EmboxOp>(loc, boxTy, boundArray, shapeOp);
+  }
+
   // Generate pointer assignment with possibly empty bounds-spec. R1035: a
   // bounds-spec is a lower bound value.
   void genPointerAssignment(
       mlir::Location loc, const Fortran::evaluate::Assignment &assign,
       const Fortran::evaluate::Assignment::BoundsSpec &lbExprs) {
     Fortran::lower::StatementContext stmtCtx;
     if (Fortran::evaluate::IsProcedure(assign.rhs))
       TODO(loc, "procedure pointer assignment");
 
     std::optional<Fortran::evaluate::DynamicType> lhsType =
         assign.lhs.GetType();
     // Delegate pointer association to unlimited polymorphic pointer
     // to the runtime. element size, type code, attribute and of
     // course base_addr might need to be updated.
     if (lhsType && lhsType->IsPolymorphic()) {
       if (!lowerToHighLevelFIR() && explicitIterationSpace())
         TODO(loc, "polymorphic pointer assignment in FORALL");
+      llvm::SmallVector<mlir::Value> lbounds;
+      for (const Fortran::evaluate::ExtentExpr &lbExpr : lbExprs)
+        lbounds.push_back(
+            fir::getBase(genExprValue(toEvExpr(lbExpr), stmtCtx)));
       mlir::Value lhs = genExprMutableBox(loc, assign.lhs).getAddr();
       mlir::Value rhs = fir::getBase(genExprBox(loc, assign.rhs, stmtCtx));
+      if (!lbounds.empty()) {
+        mlir::Value boundsDesc = createLboundArray(lbounds, loc);
+        Fortran::lower::genPointerAssociateLowerBounds(*builder, loc, lhs, rhs,
+                                                       boundsDesc);
+        return;
+      }
       Fortran::lower::genPointerAssociate(*builder, loc, lhs, rhs);
       return;
     }
 
     llvm::SmallVector<mlir::Value> lbounds;
     for (const Fortran::evaluate::ExtentExpr &lbExpr : lbExprs)
       lbounds.push_back(fir::getBase(genExprValue(toEvExpr(lbExpr), stmtCtx)));
     if (!lowerToHighLevelFIR() && explicitIterationSpace()) {

flang/lib/Lower/Runtime.cpp

void Fortran::lower::genPointerAssociateRemapping(fir::FirOpBuilder &builder,
   auto sourceFile = fir::factory::locationToFilename(builder, loc);
   auto sourceLine =
       fir::factory::locationToLineNo(builder, loc, fTy.getInput(4));
   llvm::SmallVector<mlir::Value> args = fir::runtime::createArguments(
       builder, loc, func.getFunctionType(), pointer, target, bounds, sourceFile,
       sourceLine);
   builder.create<fir::CallOp>(loc, func, args).getResult(0);
 }
+
+void Fortran::lower::genPointerAssociateLowerBounds(fir::FirOpBuilder &builder,
+                                                    mlir::Location loc,
+                                                    mlir::Value pointer,
+                                                    mlir::Value target,
+                                                    mlir::Value lbounds) {
+  mlir::func::FuncOp func =
+      fir::runtime::getRuntimeFunc<mkRTKey(PointerAssociateLowerBounds)>(
+          loc, builder);
+  llvm::SmallVector<mlir::Value> args = fir::runtime::createArguments(
+      builder, loc, func.getFunctionType(), pointer, target, lbounds);
+  builder.create<fir::CallOp>(loc, func, args).getResult(0);
+}

flang/test/Lower/polymorphic.f90

 ! CHECK: %[[C2:.*]] = arith.constant 2 : index
 ! CHECK: %[[BOUND_ARRAY_SHAPE:.*]] = fir.shape %[[C2]], %[[C1]] : (index, index) -> !fir.shape<2>
 ! CHECK: %[[BOXED_BOUND_ARRAY:.*]] = fir.embox %[[BOUND_ARRAY]](%[[BOUND_ARRAY_SHAPE]]) : (!fir.ref<!fir.array<2x1xi64>>, !fir.shape<2>) -> !fir.box<!fir.array<2x1xi64>>
 ! CHECK: %[[ARG0:.*]] = fir.convert %[[Q]] : (!fir.ref<!fir.class<!fir.ptr<!fir.array<?x!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>>>>) -> !fir.ref<!fir.box<none>>
 ! CHECK: %[[ARG1:.*]] = fir.convert %[[REBOX_A]] : (!fir.class<!fir.array<?x!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>>) -> !fir.box<none>
 ! CHECK: %[[ARG2:.*]] = fir.convert %[[BOXED_BOUND_ARRAY]] : (!fir.box<!fir.array<2x1xi64>>) -> !fir.box<none>
 ! CHECK: %{{.*}} = fir.call @_FortranAPointerAssociateRemapping(%[[ARG0]], %[[ARG1]], %[[ARG2]], %{{.*}}, %{{.*}}) {{.*}} : (!fir.ref<!fir.box<none>>, !fir.box<none>, !fir.box<none>, !fir.ref<i8>, i32) -> none
 
+  subroutine pointer_assign_lower_bounds()
+    class(p1), allocatable, target :: a(:)
+    class(p1), pointer :: p(:)
+    allocate(a(100))
+    p(-50:) => a
+  end subroutine
+
+! CHECK-LABEL: func.func @_QMpolymorphic_testPpointer_assign_lower_bounds() {
+! CHECK: %[[A:.*]] = fir.alloca !fir.class<!fir.heap<!fir.array<?x!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>>> {bindc_name = "a", fir.target, uniq_name = "_QMpolymorphic_testFpointer_assign_lower_boundsEa"}
+! CHECK: %[[P:.*]] = fir.alloca !fir.class<!fir.ptr<!fir.array<?x!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>>> {bindc_name = "p", uniq_name = "_QMpolymorphic_testFpointer_assign_lower_boundsEp"}
+! CHECK: %[[LB:.*]] = arith.constant -50 : i64
+! CHECK: %[[REBOX_A:.*]] = fir.rebox %21(%23) : (!fir.class<!fir.heap<!fir.array<?x!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>>>, !fir.shift<1>) -> !fir.class<!fir.array<?x!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>>
+! CHECK: %[[LBOUND_ARRAY:.*]] = fir.alloca !fir.array<1xi64>
+! CHECK: %[[ARRAY:.*]] = fir.undefined !fir.array<1xi64>
+! CHECK: %[[ARRAY0:.*]] = fir.insert_value %[[ARRAY]], %[[LB]], [0 : index] : (!fir.array<1xi64>, i64) -> !fir.array<1xi64>
+! CHECK: fir.store %[[ARRAY0]] to %[[LBOUND_ARRAY]] : !fir.ref<!fir.array<1xi64>>
+! CHECK: %[[C1:.*]] = arith.constant 1 : index
+! CHECK: %[[LBOUND_ARRAY_SHAPE:.*]] = fir.shape %[[C1]] : (index) -> !fir.shape<1>
+! CHECK: %[[LBOUND_ARRAY_BOXED:.*]] = fir.embox %[[LBOUND_ARRAY]](%[[LBOUND_ARRAY_SHAPE]]) : (!fir.ref<!fir.array<1xi64>>, !fir.shape<1>) -> !fir.box<!fir.array<1xi64>>
+! CHECK: %[[P_BOX_NONE:.*]] = fir.convert %[[P]] : (!fir.ref<!fir.class<!fir.ptr<!fir.array<?x!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>>>>) -> !fir.ref<!fir.box<none>>
+! CHECK: %[[A_BOX_NONE:.*]] = fir.convert %[[REBOX_A]] : (!fir.class<!fir.array<?x!fir.type<_QMpolymorphic_testTp1{a:i32,b:i32}>>>) -> !fir.box<none>
+! CHECK: %[[LBOUNDS_BOX_NONE:.*]] = fir.convert %[[LBOUND_ARRAY_BOXED]] : (!fir.box<!fir.array<1xi64>>) -> !fir.box<none>
+! CHECK: %{{.*}} = fir.call @_FortranAPointerAssociateLowerBounds(%[[P_BOX_NONE]], %[[A_BOX_NONE]], %[[LBOUNDS_BOX_NONE]]) {{.*}} : (!fir.ref<!fir.box<none>>, !fir.box<none>, !fir.box<none>) -> none
+
   subroutine test_elemental_assign()
     type(p1) :: pa(3)
     pa = [ 1, 2, 3 ]
   end subroutine
 
 ! CHECK-LABEL: func.func @_QMpolymorphic_testPtest_elemental_assign() {
 ! CHECK: %[[INT:.*]] = fir.alloca i32
 ! CHECK: %[[C3_0:.*]] = arith.constant 3 : index